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
/* *** 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
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}
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
chk (PreludeId _) = True
chk (TopLevId _) = True
chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
+ chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
\end{code}
\begin{code}
-{-LATER:
idWantsToBeINLINEd :: Id -> Bool
idWantsToBeINLINEd id
+ = panic "Id.idWantsToBeINLINEd"
+{- LATER:
= case (getIdUnfolding id) of
IWantToBeINLINEd _ -> True
_ -> False
\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
= 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
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
-- 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 ->
(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
-- 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 ->
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
\end{code}
{- LATER
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"
-}
\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}
UniqSM(..), -- type: unique supply monad
initUs, thenUs, returnUs,
- mapUs, mapAndUnzipUs,
+ mapUs, mapAndUnzipUs, mapAndUnzip3Us,
mkSplitUniqSupply,
splitUniqSupply,
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}
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}
module CoreSyn (
GenCoreBinding(..), GenCoreExpr(..),
- GenCoreArg(..),GenCoreBinder(..), GenCoreCaseAlts(..),
+ GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreCaseDefault(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
mkApp, mkCon, mkPrim,
mkValLam, mkTyLam, mkUseLam,
mkLam,
- digForLambdas,
+ collectBinders,
- collectArgs, isValArg,
+ collectArgs, isValArg, notValArg, numValArgs,
mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
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
\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
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}
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
= 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
size_up expr@(Lam _ _)
= let
- (uvars, tyvars, args, body) = digForLambdas expr
+ (uvars, tyvars, args, body) = collectBinders expr
in
size_up body `addSizeN` length args
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 (
, mkErrorApp, escErrorMsg
, argToExpr
, unTagBinders, unTagBindersAlts
+ , manifestlyWHNF, manifestlyBottom
{- exprSmallEnoughToDup,
- manifestlyWHNF, manifestlyBottom,
coreExprArity,
isWrapperFor,
maybeErrorApp,
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-} )
&& 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?
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
}
(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
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
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.
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(..)
)
-import Type ( extractTyVarsFromTy )
-import Id ( idType, getIdArity, toplevelishId, isBottomingId )
-import IdInfo -- Wanted for arityMaybe, but it seems you have
- -- to import it all... (Death to the Instance Virus!)
-import Maybes
-import UniqSet
-import Util
+import UniqSet ( unionUniqSets )
+import Usage ( UVar(..) )
+import Util ( panic, assertPanic )
\end{code}
%************************************************************************
but I might be wrong. (SLPJ, date unknown)
\begin{code}
-type CoreExprWithFVs = AnnCoreExpr Id Id FVInfo
+type CoreExprWithFVs = AnnCoreExpr Id Id TyVar UVar FVInfo
type TyVarCands = TyVarSet -- for when we carry around lists of
type IdCands = IdSet -- "candidate" TyVars/Ids.
-noTyVarCands = emptyUniqSet
-noIdCands = emptyUniqSet
-
-data FVInfo = FVInfo
- IdSet -- Free ids
- TyVarSet -- Free tyvars
- LeakInfo
-
-noFreeIds = emptyUniqSet
-noFreeTyVars = emptyUniqSet
-aFreeId i = singletonUniqSet i
-aFreeTyVar t = singletonUniqSet t
-is_among = elementOfUniqSet
-combine = unionUniqSets
-munge_id_ty i = mkUniqSet (extractTyVarsFromTy (idType i))
+noTyVarCands = emptyTyVarSet
+noIdCands = emptyIdSet
+
+data FVInfo
+ = FVInfo IdSet -- Free ids
+ TyVarSet -- Free tyvars
+ LeakInfo
+
+noFreeIds = emptyIdSet
+noFreeTyVars = emptyTyVarSet
+noFreeAnything = (noFreeIds, noFreeTyVars)
+aFreeId i = singletonIdSet i
+aFreeTyVar t = singletonTyVarSet t
+is_among = elementOfIdSet
+munge_id_ty i = tyVarsOfType (idType i)
+combine = unionUniqSets -- used both for {Id,TyVar}Sets
combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
= FVInfo (fvs1 `combine` fvs2)
(tfvs1 `combine` tfvs2)
- (leak1 `orLeak` leak2)
+ (leak1 `orLeak` leak2)
\end{code}
-Leak-free-ness is based only on the value, not the type.
-In particular, nested collections of constructors are guaranteed leak free.
-Function applications are not, except for PAPs.
+Leak-free-ness is based only on the value, not the type. In
+particular, nested collections of constructors are guaranteed leak
+free. Function applications are not, except for PAPs.
Applications of error gets (LeakFree bigArity) -- a hack!
freeVars expr = fvExpr noIdCands noTyVarCands expr
\end{code}
+%************************************************************************
+%* *
\subsection{Free variables (and types)}
+%* *
+%************************************************************************
We do the free-variable stuff by passing around ``candidates lists''
of @Ids@ and @TyVars@ that may be considered free. This is useful,
else noFreeIds)
noFreeTyVars
leakiness,
- AnnCoVar v)
+ AnnVar v)
where
leakiness
| isBottomingId v = lEAK_FREE_BIG -- Hack
Just arity -> LeakFree arity
fvExpr id_cands tyvar_cands (Lit k)
- = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k)
+ = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
-fvExpr id_cands tyvar_cands (Con c tys args)
- = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args)
+fvExpr id_cands tyvar_cands (Con c args)
+ = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
where
- args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
- tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
+ (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
-fvExpr id_cands tyvar_cands (Prim op@(CCallOp _ _ _ _ res_ty) tys args)
- = ASSERT (null tys)
- (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
+fvExpr id_cands tyvar_cands (Prim op args)
+ = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
where
- args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
- tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys)
+ (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
+ args_to_use
+ = case op of
+ CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
+ _ -> args
-fvExpr id_cands tyvar_cands (Prim op tys args)
- = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
- where
- args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
- tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
+-- this Lam stuff could probably be improved by rewriting (WDP 96/03)
+
+fvExpr id_cands tyvar_cands (Lam (UsageBinder uvar) body)
+ = panic "fvExpr:Lam UsageBinder"
-fvExpr id_cands tyvar_cands (Lam binder body)
- = (FVInfo (freeVarsOf body2 `minusUniqSet` singletonUniqSet binder)
- (freeTyVarsOf body2 `combine` munge_id_ty binder)
+fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
+ = (FVInfo (freeVarsOf body2 `minusIdSet` singletonIdSet binder)
+ (freeTyVarsOf body2 `combine` munge_id_ty binder)
leakiness,
- AnnCoLam binder body2)
+ AnnLam b body2)
where
-- We need to collect free tyvars from the binders
- body2 = fvExpr (singletonUniqSet binder `combine` id_cands) tyvar_cands body
+ body2 = fvExpr (singletonIdSet binder `combine` id_cands) tyvar_cands body
leakiness = case leakinessOf body2 of
MightLeak -> LeakFree 1
LeakFree n -> LeakFree (n + 1)
-fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
+fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
= (FVInfo (freeVarsOf body2)
- (freeTyVarsOf body2 `minusUniqSet` aFreeTyVar tyvar)
+ (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
(leakinessOf body2),
- AnnCoTyLam tyvar body2)
+ AnnLam b body2)
where
body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
+-- ditto on rewriting this App stuff (WDP 96/03)
+
fvExpr id_cands tyvar_cands (App fun arg)
- = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
- (freeTyVarsOf fun2)
+ = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
+ (freeTyVarsOf fun2 `combine` tfvs_arg)
leakiness,
- AnnCoApp fun2 arg)
+ AnnApp fun2 arg)
where
fun2 = fvExpr id_cands tyvar_cands fun
- fvs_arg = freeAtom id_cands arg
+ fun2_leakiness = leakinessOf fun2
- leakiness = case leakinessOf fun2 of
- LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
- other -> MightLeak
+ (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
-fvExpr id_cands tyvar_cands (CoTyApp expr ty)
- = (FVInfo (freeVarsOf expr2)
- (freeTyVarsOf expr2 `combine` tfvs_arg)
- (leakinessOf expr2),
- AnnCoTyApp expr2 ty)
- where
- expr2 = fvExpr id_cands tyvar_cands expr
- tfvs_arg = freeTy tyvar_cands ty
+ leakiness = if (notValArg arg) then
+ fun2_leakiness
+ else
+ case fun2_leakiness of
+ LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
+ other -> MightLeak
fvExpr id_cands tyvar_cands (Case expr alts)
= (combineFVInfo expr_fvinfo alts_fvinfo,
- AnnCoCase expr2 alts')
+ AnnCase expr2 alts')
where
expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
(alts_fvinfo, alts') = annotate_alts alts
annotate_alts (AlgAlts alts deflt)
- = (fvinfo, AnnCoAlgAlts alts' deflt')
+ = (fvinfo, AnnAlgAlts alts' deflt')
where
(alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
(deflt_fvinfo, deflt') = annotate_default deflt
fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
ann_boxed_alt (con, params, rhs)
- = (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params)
+ = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
(freeTyVarsOf rhs' `combine` param_ftvs)
(leakinessOf rhs'),
(con, params, rhs'))
where
- rhs' = fvExpr (mkUniqSet params `combine` id_cands) tyvar_cands rhs
+ rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
-- We need to collect free tyvars from the binders
annotate_alts (PrimAlts alts deflt)
- = (fvinfo, AnnCoPrimAlts alts' deflt')
+ = (fvinfo, AnnPrimAlts alts' deflt')
where
(alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
(deflt_fvinfo, deflt') = annotate_default deflt
rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
- AnnCoNoDefault)
+ AnnNoDefault)
annotate_default (BindDefault binder rhs)
- = (FVInfo (freeVarsOf rhs' `minusUniqSet` aFreeId binder)
+ = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder)
(freeTyVarsOf rhs' `combine` binder_ftvs)
(leakinessOf rhs'),
- AnnCoBindDefault binder rhs')
+ AnnBindDefault binder rhs')
where
rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
binder_ftvs = munge_id_ty binder
= (FVInfo (freeVarsOf rhs' `combine` body_fvs)
(freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
(leakinessOf rhs' `orLeak` leakinessOf body2),
- AnnCoLet (AnnCoNonRec binder rhs') body2)
+ AnnLet (AnnNonRec binder rhs') body2)
where
rhs' = fvExpr id_cands tyvar_cands rhs
body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
- body_fvs = freeVarsOf body2 `minusUniqSet` aFreeId binder
+ body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
= (FVInfo (binds_fvs `combine` body_fvs)
(rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
(leakiness_of_rhss `orLeak` leakinessOf body2),
- AnnCoLet (AnnCoRec (binders `zip` rhss')) body2)
+ AnnLet (AnnRec (binders `zip` rhss')) body2)
where
(binders, rhss) = unzip binds
new_id_cands = binders_set `combine` id_cands
- binders_set = mkUniqSet binders
+ binders_set = mkIdSet binders
rhss' = map (fvExpr new_id_cands tyvar_cands) rhss
FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
= foldr1 combineFVInfo [info | (info,_) <- rhss']
- binds_fvs = rhss_fvs `minusUniqSet` binders_set
+ binds_fvs = rhss_fvs `minusIdSet` binders_set
body2 = fvExpr new_id_cands tyvar_cands body
- body_fvs = freeVarsOf body2 `minusUniqSet` binders_set
+ body_fvs = freeVarsOf body2 `minusIdSet` binders_set
binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
-- We need to collect free tyvars from the binders
fvExpr id_cands tyvar_cands (SCC label expr)
- = (fvinfo, AnnCoSCC label expr2)
+ = (fvinfo, AnnSCC label expr2)
where
expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
\end{code}
\begin{code}
-freeAtom :: IdCands -> CoreArg -> IdSet
-
-freeAtom cands (LitArg k) = noFreeIds
-freeAtom cands (VarArg v) | v `is_among` cands = aFreeId v
- | otherwise = noFreeIds
+freeArgs :: IdCands -> TyVarCands
+ -> [CoreArg]
+ -> (IdSet, TyVarSet)
+freeArgs icands tcands [] = noFreeAnything
+freeArgs icands tcands (arg:args)
+ -- this code is written this funny way only for "efficiency" purposes
+ = let
+ free_first_arg@(arg_fvs, tfvs) = free_arg arg
+ in
+ if (null args) then
+ free_first_arg
+ else
+ case (freeArgs icands tcands args) of { (irest, trest) ->
+ (arg_fvs `combine` irest, tfvs `combine` trest) }
+ where
+ free_arg (LitArg _) = noFreeAnything
+ free_arg (UsageArg _) = noFreeAnything
+ free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty)
+ free_arg (VarArg v)
+ | v `is_among` icands = (aFreeId v, noFreeTyVars)
+ | otherwise = noFreeAnything
+
+---------
freeTy :: TyVarCands -> Type -> TyVarSet
-freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands
+freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
freeVarsOf :: CoreExprWithFVs -> IdSet
freeVarsOf (FVInfo free_vars _ _, _) = free_vars
\begin{code}
type FVCoreBinder = (Id, IdSet)
-type FVCoreExpr = GenCoreExpr FVCoreBinder Id
-type FVCoreBinding = GenCoreBinding FVCoreBinder Id
+type FVCoreExpr = GenCoreExpr FVCoreBinder Id TyVar UVar
+type FVCoreBinding = GenCoreBinding FVCoreBinder Id TyVar UVar
type InterestingIdFun
= IdSet -- Non-top-level in-scope variables
addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
-addExprFVs fv_cand in_scope (Con con tys args)
- = (Con con tys args,
+addExprFVs fv_cand in_scope (Con con args)
+ = (Con con args,
if fv_cand in_scope con
then aFreeId con
- else noFreeIds
- `combine`
- unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
+ else noFreeIds `combine` fvsOfArgs fv_cand in_scope args)
-addExprFVs fv_cand in_scope (Prim op tys args)
- = (Prim op tys args,
- unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
+addExprFVs fv_cand in_scope (Prim op args)
+ = (Prim op args, fvsOfArgs fv_cand in_scope args)
addExprFVs fv_cand in_scope (Lam binder body)
- = (Lam (binder,lam_fvs) new_body, lam_fvs)
+ = (Lam new_binder new_body, lam_fvs)
where
- binder_set = singletonUniqSet binder
- new_in_scope = in_scope `combine` binder_set
+ (new_binder, binder_set)
+ = case binder of
+ TyBinder t -> (TyBinder t, emptyIdSet)
+ UsageBinder u -> (UsageBinder u, emptyIdSet)
+ ValBinder b -> (ValBinder (b, lam_fvs),
+ singletonIdSet b)
+
+ new_in_scope = in_scope `combine` binder_set
(new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
- lam_fvs = body_fvs `minusUniqSet` binder_set
-
-addExprFVs fv_cand in_scope (CoTyLam tyvar body)
- = (CoTyLam tyvar body2, body_fvs)
- where
- (body2, body_fvs) = addExprFVs fv_cand in_scope body
+ lam_fvs = body_fvs `minusIdSet` binder_set
addExprFVs fv_cand in_scope (App fun arg)
- = (App fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
- where
- (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
-
-addExprFVs fv_cand in_scope (CoTyApp fun ty)
- = (CoTyApp fun2 ty, fun_fvs)
+ = (App fun2 arg, fun_fvs `combine` fvsOfArgs fv_cand in_scope [arg])
where
(fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
where
(alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
(deflt', deflt_fvs) = do_deflt deflt
- fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
+ fvs = unionManyIdSets (deflt_fvs : alt_fvs)
PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
where
(prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
(deflt', deflt_fvs) = do_deflt deflt
- fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
+ fvs = unionManyIdSets (deflt_fvs : alt_fvs)
do_alg_alt :: (Id, [Id], CoreExpr)
-> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
where
new_in_scope = in_scope `combine` arg_set
(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
- fvs = rhs_fvs `minusUniqSet` arg_set
- arg_set = mkUniqSet args
+ fvs = rhs_fvs `minusIdSet` arg_set
+ arg_set = mkIdSet args
do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
where
where
new_in_scope = in_scope `combine` var_set
(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
- fvs = rhs_fvs `minusUniqSet` var_set
+ fvs = rhs_fvs `minusIdSet` var_set
var_set = aFreeId var
addExprFVs fv_cand in_scope (Let binds body)
- = (Let binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
+ = (Let binds' body2, fvs_binds `combine` (fvs_body `minusIdSet` binder_set))
where
(binds', fvs_binds, new_in_scope, binder_set)
= addBindingFVs fv_cand in_scope binds
binder_set = aFreeId binder
addBindingFVs fv_cand in_scope (Rec pairs)
- = (Rec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
+ = (Rec pairs', unionManyIdSets fvs_s, new_in_scope, binder_set)
where
binders = [binder | (binder,_) <- pairs]
- binder_set = mkUniqSet binders
+ binder_set = mkIdSet binders
new_in_scope = in_scope `combine` binder_set
(pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
\end{code}
\end{code}
\begin{code}
-fvsOfAtom :: InterestingIdFun -- "Interesting id" predicate
+fvsOfArgs :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
- -> CoreArg
+ -> [CoreArg]
-> IdSet
-fvsOfAtom fv_cand in_scope (VarArg v)
- = if fv_cand in_scope v
- then aFreeId v
- else noFreeIds
-fvsOfAtom _ _ _ = noFreeIds -- if a literal...
+fvsOfArgs _ _ [] = noFreeIds
+
+fvsOfArgs fv_cand in_scope [VarArg v] -- this is only a short-cut...
+ = if (fv_cand in_scope v) then aFreeId v else noFreeIds
+fvsOfArgs _ _ [ _ ] = noFreeIds
+
+fvsOfArgs fv_cand in_scope args
+ = mkIdSet [ v | (VarArg v) <- args, fv_cand in_scope v ]
+ -- all other types of args are uninteresting here...
+----------
do_pair :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
-> IdSet
= (((binder, fvs), rhs'), fvs)
where
(rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
- fvs = rhs_fvs `minusUniqSet` binder_set
+ fvs = rhs_fvs `minusIdSet` binder_set
\end{code}
ppr_expr pe expr@(Lam _ _)
= let
- (uvars, tyvars, vars, body) = digForLambdas expr
+ (uvars, tyvars, vars, body) = collectBinders expr
in
ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar pe) uvars,
pp_vars SLIT("_/\\_") (ptyvar pe) tyvars,
import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
-import Type ( mkTyVarTy, splitSigmaTy )
-import TyVar ( GenTyVar )
+import Type ( mkTyVarTys, splitSigmaTy,
+ tyVarsOfType, tyVarsOfTypes
+ )
+import TyVar ( tyVarSetToList, GenTyVar )
import Unique ( Unique )
import Util ( isIn, panic )
-extractTyVarsFromTy = panic "DsBinds.extractTyVarsFromTy"
-extractTyVarsFromTys = panic "DsBinds.extractTyVarsFromTys"
isDictTy = panic "DsBinds.isDictTy"
quantifyTy = panic "DsBinds.quantifyTy"
\end{code}
binders = collectTypedBinders val_binds
mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
\end{code}
returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
where
locals = [local | (local,global) <- local_global_prs]
- non_ov_tyvar_tys = map mkTyVarTy non_overloaded_tyvars
+ non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
- overloaded_tyvars = extractTyVarsFromTys (map idType dicts)
- non_overloaded_tyvars = all_tyvars `minusList` overloaded_tyvars
+ overloaded_tyvars = tyVarsOfTypes (map idType dicts)
+ non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
binders = collectTypedBinders val_binds
mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
= returnDs ty_app -- Common case
| otherwise
= newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
- returnDs (mkTyLam tyvars (mkTyApp ty_app (map mkTyVarTy tyvars)))
+ returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
where
(tvs, theta, tau_ty) = splitSigmaTy (idType id)
ty_app = mkTyApp (Var id) tys
subst_item : subst_env)
where
inst_ty = idType inst
- abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars
- abs_tys = map mkTyVarTy abs_tyvars
+ abs_tyvars = tyVarsOfType inst_ty `intersectLists` tyvars
+ abs_tys = mkTyVarTys abs_tyvars
(_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
------------------------
new_alpha_tyvar :: DsM (TyVar, Type)
new_alpha_tyvar
= newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] ->
- returnDs (new_ty,mkTyVarTy new_ty)
+ returnDs (new_ty, mkTyVarTy new_ty)
\end{code}
%************************************************************************
import Id ( idType, getInstantiatedDataConSig, mkTupleCon,
DataCon(..), DictVar(..), Id(..), GenId )
import TyCon ( mkTupleTyCon )
-import Type ( mkTyVarTy, mkRhoTy, mkFunTys,
+import Type ( mkTyVarTys, mkRhoTy, mkFunTys,
applyTyCon, getAppDataTyCon )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic )
globals = [global | (local,global) <- local_global_prs]
no_of_binders = length local_global_prs
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
tuple_var_ty :: Type
tuple_var_ty
> import DefUtils
> import Def2Core ( d2c, defPanic )
-> import Type ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy,
+> import Type ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTys,
> TyVarTemplate
> )
> import Digraph ( dfs )
> mkLoopFunApp val_args ty_args f =
> foldl App
> (foldl CoTyApp (Var (DefArgVar f))
-> (map mkTyVarTy ty_args))
+> (mkTyVarTys ty_args))
> (map mkVar val_args)
-----------------------------------------------------------------------------
>#endif
> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
-> extractTyVarsFromTy, TyVar, SigmaType(..)
+> tyVarsOfType, TyVar, SigmaType(..)
> IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
> )
> import Literal ( Literal ) -- for Eq Literal
> Let (Rec bs) e -> foldr freeBind (free e tvs) bs
> SCC l e -> free e tvs
>
-> freeId id tvs = extractTyVarsFromTy (idType id) `union` tvs
-> freeTy t tvs = extractTyVarsFromTy t `union` tvs
+> freeId id tvs = tyVarsOfType (idType id) `union` tvs
+> freeTy t tvs = tyVarsOfType t `union` tvs
> freeBind (v,e) tvs = freeId v (free e tvs)
> freeAtom (VarArg (DefArgExpr e)) tvs = free e tvs
PUTTAG('e');
printf("#%lu\t",gibindline(b));
pid(gibindfile(b));
- pid(gibindmod(b));
+ pid(gibindimod(b));
/* plist(pentid,giebindexp(b)); ??? */
/* prbind(giebinddef(b)); ???? */
break;
break;
case iinst_simpl_pragma: PUTTAGSTR("Pis");
- pid(gprag_imod_simpl(p));
- ppragma(gprag_dfun_simpl(p));
+/* pid(gprag_imod_simpl(p));
+*/ ppragma(gprag_dfun_simpl(p));
break;
case iinst_const_pragma: PUTTAGSTR("Pic");
- pid(gprag_imod_const(p));
- ppragma(gprag_dfun_const(p));
+/* pid(gprag_imod_const(p));
+*/ ppragma(gprag_dfun_const(p));
plist(ppragma, gprag_constms(p));
break;
import TyCon ( mkPrimTyCon, mkDataTyCon,
ConsVisible(..), NewOrData(..) )
import TyVar ( GenTyVar(..), alphaTyVars )
-import Type ( applyTyCon, mkTyVarTy )
+import Type ( applyTyCon, mkTyVarTys )
import Usage ( usageOmega )
import Unique
\end{code}
\begin{code}
-alphaTys = map mkTyVarTy alphaTyVars
+alphaTys = mkTyVarTys alphaTyVars
(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys
\end{code}
scc_rhs rhs
= let
- (usevars, tyvars, vars, body) = digForLambdas rhs
+ (usevars, tyvars, vars, body) = collectBinders rhs
in
case body of
SCC _ _ -> rhs -- leave it
analBind (Rec binds) env =
let
first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
- (_,_,args,_) <- [digForLambdas e]]
+ (_,_,args,_) <- [collectBinders e]]
env' = delManyFromIdEnv env (map (fst.fst) binds)
in
growIdEnvList env' (fixpoint 0 binds env' first_set)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[ConFold]{Constant Folder}
module ConFold ( completePrim ) where
-import SimplEnv
-import SimplMonad
+import Ubiq{-uitous-}
-import PrelInfo ( trueDataCon, falseDataCon, PrimOp(..), PrimRep
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
+import CoreSyn
+import CoreUnfold ( UnfoldingDetails(..), FormSummary(..) )
+import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
-import Id ( Id, idType )
-import Maybes ( Maybe(..) )
-import Util
+import MagicUFs ( MagicUnfoldingFun )
+import PrelInfo ( trueDataCon, falseDataCon )
+import PrimOp ( PrimOp(..) )
+import SimplEnv
+import SimplMonad
\end{code}
\begin{code}
completePrim :: SimplEnv
- -> PrimOp -> [OutType] -> [OutAtom]
+ -> PrimOp -> [OutArg]
-> SmplM OutExpr
\end{code}
The second case must never be floated outside of the first!
\begin{code}
-completePrim env SeqOp [ty] [LitArg lit]
+completePrim env SeqOp [TyArg ty, LitArg lit]
= returnSmpl (Lit (mkMachInt 1))
-completePrim env op@SeqOp tys@[ty] args@[VarArg var]
+completePrim env op@SeqOp args@[TyArg ty, VarArg var]
= case (lookupUnfolding env var) of
- NoUnfoldingDetails -> give_up
- LitForm _ -> hooray
- OtherLitForm _ -> hooray
- ConForm _ _ _ -> hooray
- OtherConForm _ -> hooray
+ NoUnfoldingDetails -> give_up
+ LitForm _ -> hooray
+ OtherLitForm _ -> hooray
+ ConForm _ _ -> hooray
+ OtherConForm _ -> hooray
GenForm _ WhnfForm _ _ -> hooray
- _ -> give_up
+ _ -> give_up
where
- give_up = returnSmpl (Prim op tys args)
- hooray = returnSmpl (Lit (mkMachInt 1))
+ give_up = returnSmpl (Prim op args)
+ hooray = returnSmpl (Lit (mkMachInt 1))
\end{code}
\begin{code}
-completePrim env op tys args
+completePrim env op args
= case args of
- [LitArg (MachChar char_lit)] -> oneCharLit op char_lit
- [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
- op int_lit
- [LitArg (MachFloat float_lit)] -> oneFloatLit op float_lit
- [LitArg (MachDouble double_lit)] -> oneDoubleLit op double_lit
- [LitArg other_lit] -> oneLit op other_lit
-
- [LitArg (MachChar char_lit1),
- LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
+ [LitArg (MachChar char_lit)] -> oneCharLit op char_lit
+ [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
+ op int_lit
+ [LitArg (MachFloat float_lit)] -> oneFloatLit op float_lit
+ [LitArg (MachDouble double_lit)] -> oneDoubleLit op double_lit
+ [LitArg other_lit] -> oneLit op other_lit
- [LitArg (MachInt int_lit1 True), -- both *signed* literals
- LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
+ [LitArg (MachChar char_lit1),
+ LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
- [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
- LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 True), -- both *signed* literals
+ LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
- [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
- LitArg (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
+ LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
- [LitArg (MachFloat float_lit1),
- LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
+ [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
+ LitArg (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
- [LitArg (MachDouble double_lit1),
- LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
+ [LitArg (MachFloat float_lit1),
+ LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
- [LitArg lit, VarArg var] -> litVar op lit var
- [VarArg var, LitArg lit] -> litVar op lit var
+ [LitArg (MachDouble double_lit1),
+ LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
- other -> give_up
+ [LitArg lit, VarArg var] -> litVar op lit var
+ [VarArg var, LitArg lit] -> litVar op lit var
+ other -> give_up
where
- give_up = returnSmpl (Prim op tys args)
+ give_up = returnSmpl (Prim op args)
return_char c = returnSmpl (Lit (MachChar c))
return_int i = returnSmpl (Lit (mkMachInt i))
(PrimAlts [(lit,val_if_eq)]
(BindDefault unused_binder val_if_neq))
in
--- pprTrace "return_prim_case:" (ppr PprDebug result) (
returnSmpl result
--- )
--------- Ints --------------
oneIntLit IntNegOp i = return_int (-i)
twoIntLits IntLtOp i1 i2 = return_bool (i1 < i2)
twoIntLits IntLeOp i1 i2 = return_bool (i1 <= i2)
-- ToDo: something for integer-shift ops?
- twoIntLits _ _ _ = {-trace "twoIntLits: giving up"-} give_up
+ twoIntLits _ _ _ = give_up
twoWordLits WordGtOp w1 w2 = return_bool (w1 > w2)
twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
twoWordLits WordLtOp w1 w2 = return_bool (w1 < w2)
twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
-- ToDo: something for AndOp, OrOp?
- twoWordLits _ _ _ = {-trace "twoWordLits: giving up"-} give_up
+ twoWordLits _ _ _ = give_up
-- ToDo: something for shifts
- oneWordOneIntLit _ _ _ = {-trace "oneWordOneIntLit: giving up"-} give_up
+ oneWordOneIntLit _ _ _ = give_up
--------- Floats --------------
oneFloatLit FloatNegOp f = return_float (-f)
#else
-- hard to do all that in Rationals ?? (WDP 94/10) ToDo
#endif
- oneFloatLit _ _ = {-trace "oneFloatLits: giving up"-} give_up
+ oneFloatLit _ _ = give_up
twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2)
twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2)
twoFloatLits FloatSubOp f1 f2 = return_float (f1 - f2)
twoFloatLits FloatMulOp f1 f2 = return_float (f1 * f2)
twoFloatLits FloatDivOp f1 f2 | f2 /= 0 = return_float (f1 / f2)
-#if __GLASGOW_HASKELL__ <= 22
- twoFloatLits FloatPowerOp f1 f2 = return_float (f1 ** f2)
-#else
- -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
-#endif
- twoFloatLits _ _ _ = {-trace "twoFloatLits: giving up"-} give_up
+ twoFloatLits _ _ _ = give_up
--------- Doubles --------------
oneDoubleLit DoubleNegOp d = return_double (-d)
-#if __GLASGOW_HASKELL__ <= 22
- oneDoubleLit DoubleExpOp d = return_double (exp d)
- oneDoubleLit DoubleLogOp d = return_double (log d)
- oneDoubleLit DoubleSqrtOp d = return_double (sqrt d)
- oneDoubleLit DoubleSinOp d = return_double (sin d)
- oneDoubleLit DoubleCosOp d = return_double (cos d)
- oneDoubleLit DoubleTanOp d = return_double (tan d)
- oneDoubleLit DoubleAsinOp d = return_double (asin d)
- oneDoubleLit DoubleAcosOp d = return_double (acos d)
- oneDoubleLit DoubleAtanOp d = return_double (atan d)
- oneDoubleLit DoubleSinhOp d = return_double (sinh d)
- oneDoubleLit DoubleCoshOp d = return_double (cosh d)
- oneDoubleLit DoubleTanhOp d = return_double (tanh d)
-#else
- -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
-#endif
- oneDoubleLit _ _ = {-trace "oneDoubleLit: giving up"-} give_up
+ oneDoubleLit _ _ = give_up
twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2)
twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2)
twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2)
twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2)
twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2)
-#if __GLASGOW_HASKELL__ <= 22
- twoDoubleLits DoublePowerOp d1 d2 = return_double (d1 ** d2)
-#else
- -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
-#endif
- twoDoubleLits _ _ _ = {-trace "twoDoubleLits: giving up"-} give_up
+ twoDoubleLits _ _ _ = give_up
--------- Characters --------------
oneCharLit OrdOp c = return_int (fromInt (ord c))
- oneCharLit _ _ = {-trace "oneCharLIt: giving up"-} give_up
+ oneCharLit _ _ = give_up
twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2)
twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2)
twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
- twoCharLits _ _ _ = {-trace "twoCharLits: giving up"-} give_up
+ twoCharLits _ _ _ = give_up
--------- Miscellaneous --------------
oneLit Addr2IntOp (MachAddr i) = return_int i
litVar other_op lit var = give_up
-trueVal = Con trueDataCon [] []
-falseVal = Con falseDataCon [] []
+trueVal = Con trueDataCon []
+falseVal = Con falseDataCon []
\end{code}
-- and to make the interface self-sufficient...
) where
+import Ubiq{-uitous-}
+
import AnnCoreSyn
+import CoreSyn
import FreeVars
-import UniqSet
-import Util
+import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
+ elementOfIdSet, IdSet(..)
+ )
+import Util ( panic )
\end{code}
Top-level interface function, @floatInwards@. Note that we do not
%************************************************************************
\begin{code}
-type FreeVarsSet = UniqSet Id
+type FreeVarsSet = IdSet
type FloatingBinds = [(CoreBinding, FreeVarsSet)]
-- In dependency order (outermost first)
-> CoreExprWithFVs -- input expr
-> CoreExpr -- result
-fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (Var v)
+fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v)
-fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (Lit k)
+fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k)
-fiExpr to_drop (_,AnnCoCon c tys atoms)
- = mkCoLets' to_drop (Con c tys atoms)
+fiExpr to_drop (_,AnnCon c atoms)
+ = mkCoLets' to_drop (Con c atoms)
-fiExpr to_drop (_,AnnCoPrim c tys atoms)
- = mkCoLets' to_drop (Prim c tys atoms)
+fiExpr to_drop (_,AnnPrim c atoms)
+ = mkCoLets' to_drop (Prim c atoms)
\end{code}
Here we are not floating inside lambda (type lambdas are OK):
\begin{code}
-fiExpr to_drop (_,AnnCoLam binder body)
- = mkCoLets' to_drop (Lam binder (fiExpr [] body))
+fiExpr to_drop (_,AnnLam (UsageBinder binder) body)
+ = panic "FloatIn.fiExpr:AnnLam UsageBinder"
+
+fiExpr to_drop (_,AnnLam b@(ValBinder binder) body)
+ = mkCoLets' to_drop (Lam b (fiExpr [] body))
-fiExpr to_drop (_,AnnCoTyLam tyvar body)
+fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
| whnf body
-- we do not float into type lambdas if they are followed by
-- a whnf (actually we check for lambdas and constructors).
-- let f = /\t -> let v = ... in \a -> ...
-- which is bad as now f is an updatable closure (update PAP)
-- and has arity 0. This example comes from cichelli.
- = mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body))
+
+ = mkCoLets' to_drop (Lam b (fiExpr [] body))
| otherwise
- = CoTyLam tyvar (fiExpr to_drop body)
+ = Lam b (fiExpr to_drop body)
where
whnf :: CoreExprWithFVs -> Bool
- whnf (_,AnnCoLit _) = True
- whnf (_,AnnCoCon _ _ _) = True
- whnf (_,AnnCoLam _ _) = True
- whnf (_,AnnCoTyLam _ e) = whnf e
- whnf (_,AnnCoSCC _ e) = whnf e
- whnf _ = False
+
+ whnf (_,AnnLit _) = True
+ whnf (_,AnnCon _ _) = True
+ whnf (_,AnnLam (ValBinder _) _) = True
+ whnf (_,AnnLam _ e) = whnf e
+ whnf (_,AnnSCC _ e) = whnf e
+ whnf _ = False
\end{code}
Applications: we could float inside applications, but it's probably
not worth it (a purely practical choice, hunch- [not experience-]
based).
\begin{code}
-fiExpr to_drop (_,AnnCoApp fun atom)
- = mkCoLets' to_drop (App (fiExpr [] fun) atom)
-
-fiExpr to_drop (_,AnnCoTyApp expr ty)
- = CoTyApp (fiExpr to_drop expr) ty
+fiExpr to_drop (_,AnnApp fun arg)
+ | isValArg arg
+ = mkCoLets' to_drop (App (fiExpr [] fun) arg)
+ | otherwise
+ = App (fiExpr to_drop fun) arg
\end{code}
We don't float lets inwards past an SCC.
one, if it is not the same, annotate all lets in binds with current
cc, change current cc to the new one and float binds into expr.
\begin{code}
-fiExpr to_drop (_, AnnCoSCC cc expr)
+fiExpr to_drop (_, AnnSCC cc expr)
= mkCoLets' to_drop (SCC cc (fiExpr [] expr))
\end{code}
course.
\begin{code}
-fiExpr to_drop (_,AnnCoLet (AnnCoNonRec id rhs) body)
+fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body)
= fiExpr new_to_drop body
where
rhs_fvs = freeVarsOf rhs
-- Push rhs_binds into the right hand side of the binding
rhs' = fiExpr rhs_binds rhs
- rhs_fvs' = rhs_fvs `unionUniqSets` (floatedBindsFVs rhs_binds)
+ rhs_fvs' = rhs_fvs `unionIdSets` floatedBindsFVs rhs_binds
-fiExpr to_drop (_,AnnCoLet (AnnCoRec bindings) body)
+fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
= fiExpr new_to_drop body
where
(binders, rhss) = unzip bindings
-- the bindings used both in rhs and body or in more than one rhs
shared_binds
- rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs)
- (unionManyUniqSets (map floatedBindsFVs rhss_binds))
+ rhs_fvs' = unionIdSets (unionManyIdSets rhss_fvs)
+ (unionManyIdSets (map floatedBindsFVs rhss_binds))
-- Push rhs_binds into the right hand side of the binding
fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
alternatives/default [default FVs always {\em first}!].
\begin{code}
-fiExpr to_drop (_, AnnCoCase scrut alts)
+fiExpr to_drop (_, AnnCase scrut alts)
= let
fvs_scrut = freeVarsOf scrut
drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
----------------------------
-- pin default FVs on first!
--
- get_fvs_from_deflt_and_alts (AnnCoAlgAlts alts deflt)
+ get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt)
= get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
- get_fvs_from_deflt_and_alts (AnnCoPrimAlts alts deflt)
+ get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt)
= get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
- get_deflt_fvs AnnCoNoDefault = emptyUniqSet
- get_deflt_fvs (AnnCoBindDefault b rhs) = freeVarsOf rhs
+ get_deflt_fvs AnnNoDefault = emptyIdSet
+ get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs
----------------------------
- fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt)
+ fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
= AlgAlts
[ (con, params, fiExpr to_drop rhs)
| ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
(fi_default to_drop_deflt deflt)
- fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt)
+ fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
= PrimAlts
[ (lit, fiExpr to_drop rhs)
| ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
(fi_default to_drop_deflt deflt)
- fi_default to_drop AnnCoNoDefault = NoDefault
- fi_default to_drop (AnnCoBindDefault b e) = BindDefault b (fiExpr to_drop e)
+ fi_default to_drop AnnNoDefault = NoDefault
+ fi_default to_drop (AnnBindDefault b e) = BindDefault b (fiExpr to_drop e)
\end{code}
%************************************************************************
sepBindsByDropPoint drop_pts floaters
= let
(per_drop_pt, must_stay_here, _)
- --= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters
+ --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters
= split' drop_pts floaters [] empty_boxes
empty_boxes = take (length drop_pts) (repeat [])
-- only in a or unused
split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
- | all (\b -> {-b `elementOfUniqSet` a &&-}
- not (b `elementOfUniqSet` (unionManyUniqSets as)))
+ | all (\b -> {-b `elementOfIdSet` a &&-}
+ not (b `elementOfIdSet` (unionManyIdSets as)))
(bindersOf (fst bind))
= split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
where
- a' = a `unionUniqSets` fvsOfBind bind
+ a' = a `unionIdSets` fvsOfBind bind
-- not in a
split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
- | all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind))
+ | all (\b -> not (b `elementOfIdSet` a)) (bindersOf (fst bind))
= split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
where
(drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
split' aas@(a:as) (bind:binds) mult_branch drop_boxes
= split' aas' binds (bind : mult_branch) drop_boxes
where
- aas' = map (unionUniqSets (fvsOfBind bind)) aas
+ aas' = map (unionIdSets (fvsOfBind bind)) aas
-------------------------
fvsOfBind (_,fvs) = fvs
--floatedBindsFVs ::
-floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds)
+floatedBindsFVs binds = unionManyIdSets (map snd binds)
--mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
module FloatOut ( floatOutwards ) where
-import Literal ( Literal(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import CostCentre ( dupifyCC, CostCentre )
-import SetLevels
-import Id ( eqId )
-import Maybes ( Maybe(..), catMaybes, maybeToBool )
-import UniqSupply
-import Util
+import Ubiq{-uitous-}
+
+import CoreSyn
+
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
+import CostCentre ( dupifyCC )
+import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv(..),
+ GenId{-instance Outputable-}
+ )
+import Outputable ( Outputable(..){-instance (,)-} )
+import PprCore ( GenCoreBinding{-instance-} )
+import PprStyle ( PprStyle(..) )
+import PprType -- too lazy to type in all the instances
+import Pretty ( ppInt, ppStr, ppBesides, ppAboves )
+import SetLevels -- all of it
+import TyVar ( GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
+import Usage ( UVar(..) )
+import Util ( pprTrace, panic )
\end{code}
Random comments
~~~~~~~~~~~~~~~
-At the moment we never float a binding out to between two adjacent lambdas. For
-example:
+
+At the moment we never float a binding out to between two adjacent
+lambdas. For example:
+
@
\x y -> let t = x+x in ...
===>
\x -> let t = x+x in \y -> ...
@
-Reason: this is less efficient in the case where the original lambda is
-never partially applied.
+Reason: this is less efficient in the case where the original lambda
+is never partially applied.
But there's a case I've seen where this might not be true. Consider:
@
@
Well, maybe. We don't do this at the moment.
-
\begin{code}
-type LevelledExpr = GenCoreExpr (Id, Level) Id
-type LevelledBind = GenCoreBinding (Id, Level) Id
+type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
+type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
type FloatingBind = (Level, Floater)
type FloatingBinds = [FloatingBind]
-data Floater = LetFloater CoreBinding
-
- | CaseFloater (CoreExpr -> CoreExpr)
- -- Give me a right-hand side of the
- -- (usually single) alternative, and
- -- I'll build the case
+data Floater
+ = LetFloater CoreBinding
+ | CaseFloater (CoreExpr -> CoreExpr)
+ -- A CoreExpr with a hole in it:
+ -- "Give me a right-hand side of the
+ -- (usually single) alternative, and
+ -- I'll build the case..."
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-floatOutwards :: (GlobalSwitch -> Bool) -- access to all global cmd-line opts
- -> UniqSupply
- -> [CoreBinding]
- -> [CoreBinding]
+floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
-floatOutwards sw_chker us pgm
- = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
+floatOutwards us pgm
+ = case (setLevels pgm us) of { annotated_w_levels ->
- case unzip (map (floatTopBind sw_chker) annotated_w_levels)
+ case (unzip (map floatTopBind annotated_w_levels))
of { (fss, final_toplev_binds_s) ->
- (if sw_chker D_verbose_core2core
- then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
+ (if opt_D_verbose_core2core
+ then pprTrace "Levels added:\n"
+ (ppAboves (map (ppr PprDebug) annotated_w_levels))
else id
)
- ( if not (sw_chker D_simplifier_stats) then
+ ( if not (opt_D_simplifier_stats) then
id
else
let
concat final_toplev_binds_s
}}
-floatTopBind sw bind@(NonRec _ _)
- = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
+floatTopBind bind@(NonRec _ _)
+ = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
(fs, floatsToBinds floats ++ [bind'])
}
-floatTopBind sw bind@(Rec _)
- = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
+floatTopBind bind@(Rec _)
+ = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
-- Actually floats will be empty
--false:ASSERT(null floats)
(fs, [Rec (floatsToBindPairs floats ++ pairs')])
\begin{code}
-floatBind :: (GlobalSwitch -> Bool)
- -> IdEnv Level
+floatBind :: IdEnv Level
-> Level
-> LevelledBind
-> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
-floatBind sw env lvl (NonRec (name,level) rhs)
- = case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
+floatBind env lvl (NonRec (name,level) rhs)
+ = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
- case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
+ case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats',NonRec name (install heres rhs'), addOneToIdEnv env name level)
+ (fs, rhs_floats',
+ NonRec name (install heres rhs'),
+ addOneToIdEnv env name level)
}}
-floatBind sw env lvl bind@(Rec pairs)
+floatBind env lvl bind@(Rec pairs)
= case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
if not (isTopLvl bind_level) then
bind_level = getBindLevel bind
do_pair ((name, level), rhs)
- = case (floatExpr sw new_env level rhs) of { (fs, rhs_floats, rhs') ->
+ = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
- case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
+ case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (name, install heres rhs'))
}}
%************************************************************************
\begin{code}
-floatExpr :: (GlobalSwitch -> Bool)
- -> IdEnv Level
+floatExpr :: IdEnv Level
-> Level
-> LevelledExpr
-> (FloatStats, FloatingBinds, CoreExpr)
-floatExpr sw env _ (Var v) = (zero_stats, [], Var v)
-
-floatExpr sw env _ (Lit l) = (zero_stats, [], Lit l)
-
-floatExpr sw env _ (Prim op ty as) = (zero_stats, [], Prim op ty as)
-floatExpr sw env _ (Con con ty as) = (zero_stats, [], Con con ty as)
-
-floatExpr sw env lvl (App e a)
- = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
+floatExpr env _ (Var v) = (zero_stats, [], Var v)
+floatExpr env _ (Lit l) = (zero_stats, [], Lit l)
+floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
+floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
+
+floatExpr env lvl (App e a)
+ = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
(fs, floating_defns, App e' a) }
-floatExpr sw env lvl (CoTyApp e ty)
- = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
- (fs, floating_defns, CoTyApp e' ty) }
+floatExpr env lvl (Lam (UsageBinder _) e)
+ = panic "FloatOut.floatExpr: Lam UsageBinder"
-floatExpr sw env lvl (CoTyLam tv e)
+floatExpr env lvl (Lam (TyBinder tv) e)
= let
incd_lvl = incMinorLvl lvl
in
- case (floatExpr sw env incd_lvl e) of { (fs, floats, e') ->
+ case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
- (fs, floats', CoTyLam tv (install heres e'))
+ (fs, floats', Lam (TyBinder tv) (install heres e'))
}}
-floatExpr sw env lvl (Lam (arg,incd_lvl) rhs)
+floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
= let
new_env = addOneToIdEnv env arg incd_lvl
in
- case (floatExpr sw new_env incd_lvl rhs) of { (fs, floats, rhs') ->
+ case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
(add_to_stats fs floats',
floats',
- Lam args' (install heres rhs'))
+ Lam (ValBinder arg) (install heres rhs'))
}}
-floatExpr sw env lvl (SCC cc expr)
- = case (floatExpr sw env lvl expr) of { (fs, floating_defns, expr') ->
+floatExpr env lvl (SCC cc expr)
+ = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
let
-- annotate bindings floated outwards past an scc expression
-- with the cc. We mark that cc as "duplicated", though.
ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
- ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
- ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
- ann_rhs rhs@(Con _ _ _)= rhs -- no point in scc'ing WHNF data
- ann_rhs rhs = SCC dupd_cc rhs
+ ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
+ ann_rhs rhs@(Con _ _) = rhs -- no point in scc'ing WHNF data
+ ann_rhs rhs = SCC dupd_cc rhs
-- Note: Nested SCC's are preserved for the benefit of
-- cost centre stack profiling (Durham)
-floatExpr sw env lvl (Let bind body)
- = case (floatBind sw env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
- case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
+floatExpr env lvl (Let bind body)
+ = case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
+ case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
(add_stats fsb fse,
rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
body')
where
bind_lvl = getBindLevel bind
-floatExpr sw env lvl (Case scrut alts)
- = case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
+floatExpr env lvl (Case scrut alts)
+ = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
case (scrut', float_alts alts) of
-
-{- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94)
+ (_, (fsa, fda, alts')) ->
+ (add_stats fse fsa, fda ++ fde, Case scrut' alts')
+ }
+ {- OLD CASE-FLOATING CODE: DROPPED FOR NOW. (SLPJ 7/2/94)
(Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
| scrut_var_lvl `ltMajLvl` lvl ->
Nothing -> Level 0 0
Just lvl -> unTopify lvl
- END OF CASE FLOATING DROPPED -}
-
- (_, (fsa, fda, alts')) ->
-
- (add_stats fse fsa, fda ++ fde, Case scrut' alts')
- }
+ END OF CASE FLOATING DROPPED -}
where
incd_lvl = incMinorLvl lvl
bs' = map fst bs
new_env = growIdEnvList env bs
in
- case (floatExpr sw new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
+ case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (con, bs', install heres rhs')) }}
--------------
float_prim_alt (lit, rhs)
- = case (floatExpr sw env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
+ = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (lit, install heres rhs')) }}
float_deflt NoDefault = (zero_stats, [], NoDefault)
float_deflt (BindDefault (b,lvl) rhs)
- = case (floatExpr sw new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
+ = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', BindDefault b (install heres rhs')) }}
where
| FBGoodProd == prod ->
{- || any (== FBGoodConsum) consum -}
let
- (use_args,big_args,args,body) = digForLambdas expr'
+ (use_args,big_args,args,body) = collectBinders expr'
in
if length args /= length consum -- funny number of arguments
then returnWw [(id,expr')]
%
-% (c) The AQUA Project, Glasgow University, 1994
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
+96/03: We aren't using this at the moment
\begin{code}
#include "HsVersions.h"
module LiberateCase ( liberateCase ) where
+import Ubiq{-uitous-}
+import Util ( panic )
+
+liberateCase = panic "LiberateCase.liberateCase: ToDo"
+
+{- LATER: to end of file:
import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( localiseId, toplevelishId{-debugging-} )
import Maybes
= not (null free_scruts)
where
free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
+-}
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
%* *
%************************************************************************
+96/03: We aren't using the static-argument transformation right now.
+
May be seen as removing invariants from loops:
Arguments of recursive functions that do not change in recursive
calls are removed from the recursion, which is done locally
\begin{code}
#include "HsVersions.h"
-module SAT (
- doStaticArgs
+module SAT ( doStaticArgs ) where
+
+import Ubiq{-uitous-}
+import Util ( panic )
- -- and to make the interface self-sufficient...
- ) where
+doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
+
+{- LATER: to end of file:
import Maybes ( Maybe(..) )
import SATMonad
get e
= satExpr e `thenSAT` \ e2 ->
returnSAT (e2, Nothing)
+-}
\end{code}
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
%* *
%************************************************************************
+96/03: We aren't using the static-argument transformation right now.
+
\begin{code}
#include "HsVersions.h"
+module SATMonad where
+
+import Ubiq{-uitous-}
+import Util ( panic )
+
+junk_from_SATMonad = panic "SATMonad.junk"
+
+{- LATER: to end of file:
+
module SATMonad (
SATInfo(..), updSAEnv,
SatM(..), initSAT, emptyEnvSAT,
) where
import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
- extractTyVarsFromTy, splitSigmaTy, splitTyArgs,
+ splitSigmaTy, splitTyArgs,
glueTyArgs, instantiateTy, TauType(..),
Class, ThetaType(..), SigmaType(..),
InstTyEnv(..)
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
= let
- (uvs, tvs, lambda_bounds, body) = digForLambdas expr
+ (uvs, tvs, lambda_bounds, body) = collectBinders expr
in
([ Static (mkTyVarTy tv) | tv <- tvs ],
[ Static v | v <- lambda_bounds ])
-- this binder *will* get inlined but if it happen to be
-- a top level binder it is never removed as dead code,
-- therefore we have to remove that information (of it being
- -- top-level or exported somehow.
+ -- top-level or exported somehow.)
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
fake_binder = mkSysLocal
isStatic :: Arg a -> Bool
isStatic NotStatic = False
isStatic _ = True
+-}
\end{code}
-- not exported: , incMajorLvl, isTopMajLvl, unTopify
) where
-import Type ( isPrimType, isLeakFreeType, mkTyVarTy,
- quantifyTy, TyVarTemplate -- Needed for quantifyTy
- )
+import Ubiq{-uitous-}
+
import AnnCoreSyn
-import Literal ( Literal(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import FreeVars
-import Id ( mkSysLocal, idType, eqId,
- isBottomingId, toplevelishId, DataCon(..)
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
+import CoreSyn
+
+import CoreUtils ( coreExprType, manifestlyWHNF, manifestlyBottom )
+import FreeVars -- all of it
+import Id ( idType, mkSysLocal, toplevelishId,
+ nullIdEnv, addOneToIdEnv, growIdEnvList,
+ unionManyIdSets, minusIdSet, mkIdSet,
+ idSetToList,
+ lookupIdEnv, IdEnv(..)
+ )
+import Pretty ( ppStr, ppBesides, ppChar, ppInt )
+import SrcLoc ( mkUnknownSrcLoc )
+import Type ( isPrimType, mkTyVarTys )
+import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
+ growTyVarEnvList, lookupTyVarEnv,
+ tyVarSetToList,
+ TyVarEnv(..),
+ unionManyTyVarSets
)
-import Maybes ( Maybe(..) )
-import Pretty -- debugging only
-import UniqSet
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import UniqSupply
-import Util
+import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
+ mapAndUnzip3Us, getUnique, UniqSM(..)
+ )
+import Usage ( UVar(..) )
+import Util ( mapAccumL, zipWithEqual, panic, assertPanic )
+
+quantifyTy = panic "SetLevels.quantifyTy (ToDo)"
+isLeakFreeType = panic "SetLevels.isLeakFreeType (ToDo)"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data Level = Level
- Int -- Level number of enclosing lambdas
- Int -- Number of big-lambda and/or case expressions between
- -- here and the nearest enclosing lambda
-
- | Top -- Means *really* the top level.
+data Level
+ = Top -- Means *really* the top level.
+ | Level Int -- Level number of enclosing lambdas
+ Int -- Number of big-lambda and/or case expressions between
+ -- here and the nearest enclosing lambda
\end{code}
The {\em level number} on a (type-)lambda-bound variable is the
-nesting depth of the (type-)lambda which binds it. On an expression, it's the
-maximum level number of its free (type-)variables. On a let(rec)-bound
-variable, it's the level of its RHS. On a case-bound variable, it's
-the number of enclosing lambdas.
+nesting depth of the (type-)lambda which binds it. On an expression,
+it's the maximum level number of its free (type-)variables. On a
+let(rec)-bound variable, it's the level of its RHS. On a case-bound
+variable, it's the number of enclosing lambdas.
Top-level variables: level~0. Those bound on the RHS of a top-level
definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
x_1 = ... b ... in ...
\end{verbatim}
-Level 0 0 will make something get floated to a top-level "equals", @Top@
-makes it go right to the top.
+Level 0 0 will make something get floated to a top-level "equals",
+@Top@ makes it go right to the top.
-The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). That's
-meant to be the level number of the enclosing binder in the final (floated)
-program. If the level number of a sub-expression is less than that of the
-context, then it might be worth let-binding the sub-expression so that it
-will indeed float. This context level starts at @Level 0 0@; it is never @Top@.
+The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
+That's meant to be the level number of the enclosing binder in the
+final (floated) program. If the level number of a sub-expression is
+less than that of the context, then it might be worth let-binding the
+sub-expression so that it will indeed float. This context level starts
+at @Level 0 0@; it is never @Top@.
\begin{code}
-type LevelledExpr = GenCoreExpr (Id, Level) Id
-type LevelledAtom = GenCoreAtom Id
-type LevelledBind = GenCoreBinding (Id, Level) Id
+type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
+type LevelledArg = GenCoreArg Id TyVar UVar
+type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
type LevelEnvs = (IdEnv Level, -- bind Ids to levels
TyVarEnv Level) -- bind type variables to levels
-tOP_LEVEL = Top
+tOP_LEVEL = Top
incMajorLvl :: Level -> Level
incMajorLvl Top = Level 1 0
ltLvl :: Level -> Level -> Bool
ltLvl l1 Top = False
ltLvl Top (Level _ _) = True
-ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) ||
- (maj1 == maj2 && min1 < min2)
+ltLvl (Level maj1 min1) (Level maj2 min2)
+ = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
-ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft
- -- *lambda* level to another
+ltMajLvl :: Level -> Level -> Bool
+ -- Tells if one level belongs to a difft *lambda* level to another
ltMajLvl l1 Top = False
ltMajLvl Top (Level 0 _) = False
ltMajLvl Top (Level _ _) = True
isTopLvl Top = True
isTopLvl other = False
-isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
+isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
isTopMajLvl Top = True
isTopMajLvl (Level maj _) = maj == 0
\begin{code}
setLevels :: [CoreBinding]
- -> (GlobalSwitch -> Bool) -- access to all global cmd-line opts
-> UniqSupply
-> [LevelledBind]
-setLevels binds sw us
- = do_them binds sw us
+setLevels binds us
+ = do_them binds us
where
-- "do_them"'s main business is to thread the monad along
-- It gives each top binding the same empty envt, because
initial_envs = (nullIdEnv, nullTyVarEnv)
--- OLDER:
lvlTopBind (NonRec binder rhs)
- = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs))
+ = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
lvlTopBind (Rec pairs)
- = lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs])
-
-{- NEWER: Too bad about the types: WDP:
-lvlTopBind (NonRec binder rhs)
- = {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars!
- lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet)
-
-lvlTopBind (Rec pairs)
- = lvlBind (Level 0 0) initial_envs
- (AnnCoRec [(b, emptyUniqSet)
- | (b, rhs) <- pairs,
- {-SIGH:ditto:ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} True])
--}
+ = lvlBind (Level 0 0) initial_envs (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
\end{code}
%************************************************************************
The binding stuff works for top level too.
\begin{code}
-type CoreBindingWithFVs = AnnCoreBinding Id Id FVInfo
+type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo
lvlBind :: Level
-> LevelEnvs
-> CoreBindingWithFVs
-> LvlM ([LevelledBind], LevelEnvs)
-lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs)
+lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
= setFloatLevel True {- Already let-bound -}
ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
let
ty = idType name
-lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
+lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
= decideRecFloatLevel ctxt_lvl envs binders rhss
`thenLvl` \ (final_lvl, extra_binds, rhss') ->
let
If there were another lambda in @r@'s rhs, it would get level-2 as well.
\begin{code}
-lvlExpr _ _ (_, AnnCoVar v) = returnLvl (Var v)
-lvlExpr _ _ (_, AnnCoLit l) = returnLvl (Lit l)
-lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (Con con tys atoms)
-lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (Prim op tys atoms)
+lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
+lvlExpr _ _ (_, AnnLit l) = returnLvl (Lit l)
+lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
+lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty)
- = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (CoTyApp expr' ty)
-
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg)
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
= lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
returnLvl (App fun' arg)
-lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr)
+lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (SCC cc expr')
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
- = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
- returnLvl (CoTyLam tyvar e')
- where
- incd_lvl = incMinorLvl ctxt_lvl
- new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
-
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam arg rhs)
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
= lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
- returnLvl (Lam (arg,incd_lvl) rhs')
+ returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
where
incd_lvl = incMajorLvl ctxt_lvl
new_venv = growIdEnvList venv [(arg,incd_lvl)]
-lvlExpr ctxt_lvl envs (_, AnnCoLet bind body)
+lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
+ = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
+ returnLvl (Lam (TyBinder tyvar) e')
+ where
+ incd_lvl = incMinorLvl ctxt_lvl
+ new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
+
+lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
+ = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
+
+lvlExpr ctxt_lvl envs (_, AnnLet bind body)
= lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
= lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
lvl_alts alts `thenLvl` \ alts' ->
returnLvl (Case expr' alts')
expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
- lvl_alts (AnnCoAlgAlts alts deflt)
+ lvl_alts (AnnAlgAlts alts deflt)
= mapLvl lvl_alt alts `thenLvl` \ alts' ->
lvl_deflt deflt `thenLvl` \ deflt' ->
returnLvl (AlgAlts alts' deflt')
lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
returnLvl (con, bs', e')
- lvl_alts (AnnCoPrimAlts alts deflt)
+ lvl_alts (AnnPrimAlts alts deflt)
= mapLvl lvl_alt alts `thenLvl` \ alts' ->
lvl_deflt deflt `thenLvl` \ deflt' ->
returnLvl (PrimAlts alts' deflt')
= lvlMFE incd_lvl envs e `thenLvl` \ e' ->
returnLvl (lit, e')
- lvl_deflt AnnCoNoDefault = returnLvl NoDefault
+ lvl_deflt AnnNoDefault = returnLvl NoDefault
- lvl_deflt (AnnCoBindDefault b expr)
+ lvl_deflt (AnnBindDefault b expr)
= let
new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
in
-- The truth: better to give it expr_lvl in case it is pinning
-- something non-trivial which depends on it.
where
- fv_list = uniqSetToList fvs
- tv_list = uniqSetToList tfvs
+ fv_list = idSetToList fvs
+ tv_list = tyVarSetToList tfvs
expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
de_ann_expr = deAnnotate expr
- is_trivial (CoTyApp e _) = is_trivial e
- is_trivial (Var _) = True
- is_trivial _ = False
+ is_trivial (App e a)
+ | notValArg a = is_trivial e
+ is_trivial (Var _) = True
+ is_trivial _ = False
offending_tyvars = filter offending tv_list
--non_offending_tyvars = filter (not . offending) tv_list
= lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
newLvlVar poly_ty `thenLvl` \ poly_var ->
let
- poly_var_rhs = mkCoTyLam offending_tyvars expr'
+ poly_var_rhs = mkTyLam offending_tyvars expr'
poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
- poly_var_app = mkCoTyApps (Var poly_var) (map mkTyVarTy offending_tyvars)
+ poly_var_app = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
in
returnLvl final_expr
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
- d_rhss = [ mkCoTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
+ d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
-- "local_binds" are "D'" in the documentation above
local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
- poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr Let rhs' local_binds)
+ poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
| rhs' <- rhss' -- mkCoLet* requires Core...
]
where
tys = map idType ids
- fvs = unionManyUniqSets [freeVarsOf rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids
- tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss]
- fv_list = uniqSetToList fvs
- tv_list = uniqSetToList tfvs
+ fvs = unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
+ tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
+ fv_list = idSetToList fvs
+ tv_list = tyVarSetToList tfvs
ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
| ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
| otherwise = []
- offending_tyvar_tys = map mkTyVarTy offending_tyvars
+ offending_tyvar_tys = mkTyVarTys offending_tyvars
poly_tys = [ snd (quantifyTy offending_tyvars ty)
| ty <- tys
]
********** -}
isWorthFloatingExpr :: CoreExpr -> Bool
-isWorthFloatingExpr (Var v) = False
-isWorthFloatingExpr (Lit lit) = False
-isWorthFloatingExpr (Con con tys []) = False -- Just a type application
-isWorthFloatingExpr (CoTyApp expr ty) = isWorthFloatingExpr expr
-isWorthFloatingExpr other = True
+
+isWorthFloatingExpr (Var v) = False
+isWorthFloatingExpr (Lit lit) = False
+isWorthFloatingExpr (App e arg)
+ | notValArg arg = isWorthFloatingExpr e
+isWorthFloatingExpr (Con con as)
+ | all notValArg as = False -- Just a type application
+isWorthFloatingExpr _ = True
canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
%************************************************************************
\begin{code}
-type LvlM result
- = (GlobalSwitch -> Bool) -> UniqSupply -> result
-
-thenLvl m k sw us
- = case splitUniqSupply us of { (s1, s2) ->
- case m sw s1 of { m_result ->
- k m_result sw s2 }}
-
-returnLvl v sw us = v
-
-mapLvl f [] = returnLvl []
-mapLvl f (x:xs)
- = f x `thenLvl` \ r ->
- mapLvl f xs `thenLvl` \ rs ->
- returnLvl (r:rs)
-
-mapAndUnzipLvl f [] = returnLvl ([], [])
-mapAndUnzipLvl f (x:xs)
- = f x `thenLvl` \ (r1, r2) ->
- mapAndUnzipLvl f xs `thenLvl` \ (rs1, rs2) ->
- returnLvl (r1:rs1, r2:rs2)
-
-mapAndUnzip3Lvl f [] = returnLvl ([], [], [])
-mapAndUnzip3Lvl f (x:xs)
- = f x `thenLvl` \ (r1, r2, r3) ->
- mapAndUnzip3Lvl f xs `thenLvl` \ (rs1, rs2, rs3) ->
- returnLvl (r1:rs1, r2:rs2, r3:rs3)
+type LvlM result = UniqSM result
+
+thenLvl = thenUs
+returnLvl = returnUs
+mapLvl = mapUs
+mapAndUnzipLvl = mapAndUnzipUs
+mapAndUnzip3Lvl = mapAndUnzip3Us
\end{code}
We create a let-binding for `interesting' (non-utterly-trivial)
\begin{code}
newLvlVar :: Type -> LvlM Id
-newLvlVar ty sw us
- = id
- where
- id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc
- uniq = getUnique us
+newLvlVar ty us
+ = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
\end{code}
)
import Type ( splitSigmaTy, splitTyArgs, glueTyArgs,
getTyConFamilySize, isPrimType,
- maybeDataTyCon
+ maybeAppDataTyCon
)
import Literal ( isNoRepLit, Literal )
import CmdLineOpts ( SimplifierSwitch(..) )
let
final_rhs
= (if switchIsSet new_env SimplDoEtaReduction
- then mkCoLamTryingEta
+ then mkValLamTryingEta
else mkValLam) used_args' rhs'
in
returnSmpl (NonRec rhs_fun_id final_rhs,
v | scrut_is_var = Var scrut_var
| otherwise = Con con arg_tys (map VarArg args)
- arg_tys = case maybeDataTyCon (idType deflt_var) of
+ arg_tys = case maybeAppDataTyCon (idType deflt_var) of
Just (_, arg_tys, _) -> arg_tys
mkCoCase scrut (PrimAlts
rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
rhs_looks_like_a_data_val
- = case (digForLambdas rhs) of
+ = case (collectBinders rhs) of
(_, _, [], Con _ _ _) -> True
other -> False
rhs_arg_tys
- = case (digForLambdas rhs) of
+ = case (collectBinders rhs) of
(_, _, val_binders, _) -> map idType val_binders
(mentioned_ids, _, _, mentions_litlit)
floatExposesHNF,
- mkCoTyLamTryingEta, mkCoLamTryingEta,
+ mkTyLamTryingEta, mkValLamTryingEta,
etaExpandCount,
type_ok_for_let_to_case
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
+import Ubiq{-uitous-}
+import BinderInfo
+import CoreSyn
+import CoreUtils ( manifestlyWHNF )
+import Id ( idType, isBottomingId, getIdArity )
+import IdInfo ( arityMaybe )
+import Maybes ( maybeToBool )
+import PrelInfo ( augmentId, buildId, realWorldStateTy )
import SimplEnv
import SimplMonad
+import Type ( isPrimType, maybeAppDataTyCon, getTyVar_maybe )
+import Util ( isIn, panic )
-import BinderInfo
-
-import PrelInfo ( primOpIsCheap, realWorldStateTy,
- buildId, augmentId
- IF_ATTACK_PRAGMAS(COMMA realWorldTy)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( extractTyVarsFromTy, getTyVarMaybe, isPrimType,
- splitTypeWithDictsAsArgs, maybeDataTyCon,
- applyTy, isFunType, TyVar, TyVarTemplate
- )
-import Id ( getInstantiatedDataConSig, isDataCon, idType,
- getIdArity, isBottomingId, idWantsToBeINLINEd,
- DataCon(..), Id
- )
-import IdInfo
-import CmdLineOpts ( SimplifierSwitch(..) )
-import Maybes ( maybeToBool, Maybe(..) )
-import Outputable -- isExported ...
-import Util
+primOpIsCheap = panic "SimplUtils. (ToDo)"
\end{code}
-- because it *will* become one.
-- likewise for `augment g h'
--
- try (App (CoTyApp (Var bld) _) _) | bld == buildId = True
- try (App (App (CoTyApp (Var bld) _) _) _) | bld == augmentId = True
+ try (App (App (Var bld) _) _) | bld == buildId = True
+ try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
try other = manifestlyWHNF other
{- but *not* necessarily "manifestlyBottom other"...
to allocate it eagerly as that's a waste.
-}
- try_alt (lit,rhs) = try rhs
+ try_alt (lit,rhs) = try rhs
try_deflt NoDefault = False
try_deflt (BindDefault _ rhs) = try rhs
f turns out to be just a single call to this recursive function.
\begin{code}
-mkCoLamTryingEta :: [Id] -- Args to the lambda
+mkValLamTryingEta :: [Id] -- Args to the lambda
-> CoreExpr -- Lambda body
-> CoreExpr
-mkCoLamTryingEta [] body = body
+mkValLamTryingEta [] body = body
-mkCoLamTryingEta orig_ids body
+mkValLamTryingEta orig_ids body
= reduce_it (reverse orig_ids) body
where
bale_out = mkValLam orig_ids body
reduce_it ids other = bale_out
- is_elem = isIn "mkCoLamTryingEta"
+ is_elem = isIn "mkValLamTryingEta"
-----------
residual_ok :: CoreExpr -> Bool -- Checks for type application
- -- and function not one of the
- -- bound vars
- residual_ok (CoTyApp fun ty) = residual_ok fun
- residual_ok (Var v) = not (v `is_elem` orig_ids) -- Fun mustn't be one of
- -- the bound ids
- residual_ok other = False
+ -- and function not one of the
+ -- bound vars
+
+ residual_ok (Var v) = not (v `is_elem` orig_ids)
+ -- Fun mustn't be one of the bound ids
+ residual_ok (App fun arg)
+ | notValArg arg = residual_ok fun
+ residual_ok other = False
\end{code}
Eta expansion
E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
-is a safe transformation. In particular, the transformation should not
-cause work to be duplicated, unless it is ``cheap'' (see @manifestlyCheap@ below).
+is a safe transformation. In particular, the transformation should
+not cause work to be duplicated, unless it is ``cheap'' (see
+@manifestlyCheap@ below).
-@etaExpandCount@ errs on the conservative side. It is always safe to return 0.
+@etaExpandCount@ errs on the conservative side. It is always safe to
+return 0.
An application of @error@ is special, because it can absorb as many
-arguments as you care to give it. For this special case we return 100,
-to represent "infinity", which is a bit of a hack.
+arguments as you care to give it. For this special case we return
+100, to represent "infinity", which is a bit of a hack.
\begin{code}
etaExpandCount :: GenCoreExpr bdr Id
- -> Int -- Number of extra args you can safely abstract
+ -> Int -- Number of extra args you can safely abstract
-etaExpandCount (Lam _ body)
+etaExpandCount (Lam (ValBinder _) body)
= 1 + etaExpandCount body
etaExpandCount (Let bind body)
| manifestlyCheap scrut
= minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
-etaExpandCount (App fun _) = case etaExpandCount fun of
- 0 -> 0
- n -> n-1 -- Knock off one
-
-etaExpandCount fun@(CoTyApp _ _) = eta_fun fun
etaExpandCount fun@(Var _) = eta_fun fun
+etaExpandCount (App fun arg)
+ | notValArg arg = eta_fun fun
+ | otherwise = case etaExpandCount fun of
+ 0 -> 0
+ n -> n-1 -- Knock off one
-etaExpandCount other = 0 -- Give up
+etaExpandCount other = 0 -- Give up
-- Lit, Con, Prim,
- -- CoTyLam,
+ -- non-val Lam,
-- Scc (pessimistic; ToDo),
-- Let with non-whnf rhs(s),
-- Case with non-whnf scrutinee
+-----------------------------
eta_fun :: GenCoreExpr bdr Id -- The function
-> Int -- How many args it can safely be applied to
-eta_fun (CoTyApp fun ty) = eta_fun fun
+eta_fun (App fun arg) | notValArg arg = eta_fun fun
eta_fun expr@(Var v)
- | isBottomingId v -- Bottoming ids have "infinite arity"
- = 10000 -- Blargh. Infinite enough!
+ | isBottomingId v -- Bottoming ids have "infinite arity"
+ = 10000 -- Blargh. Infinite enough!
eta_fun expr@(Var v)
- | maybeToBool arity_maybe -- We know the arity
+ | maybeToBool arity_maybe -- We know the arity
= arity
where
arity_maybe = arityMaybe (getIdArity v)
arity = case arity_maybe of { Just arity -> arity }
-eta_fun other = 0 -- Give up
+eta_fun other = 0 -- Give up
\end{code}
@manifestlyCheap@ looks at a Core expression and returns \tr{True} if
manifestlyCheap (Var _) = True
manifestlyCheap (Lit _) = True
manifestlyCheap (Con _ _ _) = True
-manifestlyCheap (Lam _ _) = True
-manifestlyCheap (CoTyLam _ e) = manifestlyCheap e
manifestlyCheap (SCC _ e) = manifestlyCheap e
+manifestlyCheap (Lam (ValBinder _) _) = True
+manifestlyCheap (Lam other_binder e) = manifestlyCheap e
+
manifestlyCheap (Prim op _ _) = primOpIsCheap op
manifestlyCheap (Let bind body)
= 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!
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
+ 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
}
/\ a -> f Char# a =NO=> f Char#
\begin{code}
-mkCoTyLamTryingEta :: [TyVar] -> CoreExpr -> CoreExpr
+mkTyLamTryingEta :: [TyVar] -> CoreExpr -> CoreExpr
-mkCoTyLamTryingEta tyvars tylam_body
+mkTyLamTryingEta tyvars tylam_body
= if
tyvars == tyvar_args && -- Same args in same order
check_fun fun -- Function left is ok
fun
else
-- The vastly common case
- mkCoTyLam tyvars tylam_body
+ mkTyLam tyvars tylam_body
where
(tyvar_args, fun) = strip_tyvar_args [] tylam_body
- strip_tyvar_args args_so_far tyapp@(CoTyApp fun ty)
- = case getTyVarMaybe ty of
+ strip_tyvar_args args_so_far tyapp@(App fun (TyArg ty))
+ = case getTyVar_maybe ty of
Just tyvar_arg -> strip_tyvar_args (tyvar_arg:args_so_far) fun
Nothing -> (args_so_far, tyapp)
+ strip_tyvar_args args_so_far (App _ (UsageArg _))
+ = panic "SimplUtils.mkTyLamTryingEta: strip_tyvar_args UsageArg"
+
strip_tyvar_args args_so_far fun
= (args_so_far, fun)
returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder)))
| otherwise
- = case maybeDataTyCon rhs_ty of
+ = case (maybeAppDataTyCon rhs_ty) of
Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking
let
(_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args
type_ok_for_let_to_case :: Type -> Bool
type_ok_for_let_to_case ty
- = case maybeDataTyCon ty of
+ = case (maybeAppDataTyCon ty) of
Nothing -> False
Just (tycon, ty_args, []) -> False
Just (tycon, ty_args, non_null_data_cons) -> True
rhs_looks_like_a_Con
= let
- (_,_,val_binders,body) = digForLambdas template
+ (_,_,val_binders,body) = collectBinders template
in
case (val_binders, body) of
([], Con _ _ _) -> True
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import Type ( maybeDataTyCon, mkTyVarTy, applyTy,
+import Type ( maybeAppDataTyCon, mkTyVarTy, mkTyVarTys, applyTy,
splitTyArgs, splitTypeWithDictsAsArgs,
maybeUnpackFunTy, isPrimType
)
We only eta-reduce a type lambda if all type arguments in the body can
be eta-reduced. This requires us to collect up all tyvar parameters so
-we can pass them all to @mkCoTyLamTryingEta@.
+we can pass them all to @mkTyLamTryingEta@.
\begin{code}
simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
= simplExpr env body [] `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
- then mkCoTyLamTryingEta
+ then mkTyLamTryingEta
else mkCoTyLam) (reverse tyvars') body'
)
= -- Deal with the big lambda part
mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
let
- lam_env = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
+ lam_env = extendTyEnvList rhs_env (tyvars `zip` (mkTyVarTys tyvars'))
in
-- Deal with the little lambda part
-- Note that we call simplLam even if there are no binders, in case
-- Put it back together
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
- then mkCoTyLamTryingEta
+ then mkTyLamTryingEta
else mkCoTyLam) tyvars' lambda'
)
where
rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
| otherwise = env
- (uvars, tyvars, binders, body) = digForLambdas rhs
+ (uvars, tyvars, binders, body) = collectBinders rhs
min_no_of_args | not (null binders) && -- It's not a thunk
switchIsSet env SimplDoArityExpand -- Arity expansion on
simplExpr new_env body [] `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
- then mkCoLamTryingEta
+ then mkValLamTryingEta
else mkValLam) binders' body'
)
simplExpr new_env body (map (ValArg.VarArg) extra_binders') `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
- then mkCoLamTryingEta
+ then mkValLamTryingEta
else mkValLam) (binders' ++ extra_binders') body'
)
getArgLists, saTransform
) where
-import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
- extractTyVarsFromTy, splitSigmaTy, splitTyArgs,
+import Type ( mkSigmaTy, TyVarTemplate,
+ splitSigmaTy, splitTyArgs,
glueTyArgs, instantiateTy, TauType(..),
Class, ThetaType(..), SigmaType(..),
InstTyEnv(..)
-- to look at the type of the dictionary itself.
-- Doing the proper job would entail keeping track of free tyvars as
-- well as free vars, which would be a bore.
- db_ftvs = mkUniqSet (extractTyVarsFromTys (map idType dbinders))
+ db_ftvs = tyVarsOfTypes (map idType dbinders)
\end{code}
%************************************************************************
= lintStgExpr scrut `thenMaybeL` \ _ ->
-- Check that it is a data type
- case maybeDataTyCon scrut_ty of
+ case maybeAppDataTyCon scrut_ty of
Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
returnL Nothing
Just (tycon, _, _)
Just _ -> returnL () -- that's cool
lintAlgAlt scrut_ty (con, args, _, rhs)
- = (case maybeDataTyCon scrut_ty of
+ = (case maybeAppDataTyCon scrut_ty of
Nothing ->
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
floatTyCon, wordTyCon, addrTyCon,
PrimRep
)
-import Type ( isPrimType, maybeDataTyCon,
+import Type ( isPrimType, maybeAppDataTyCon,
maybeSingleConstructorTyCon,
returnsRealWorld,
isEnumerationTyCon, TyVarTemplate, TyCon
else -- It's strict (or we're pretending it is)!
- case maybeDataTyCon ty of
+ case maybeAppDataTyCon ty of
Nothing -> wwStrict
(all_strict, num_strict) = strflags
is_numeric_type ty
- = case (maybeDataTyCon ty) of -- NB: duplicates stuff done above
+ = case (maybeAppDataTyCon ty) of -- NB: duplicates stuff done above
Nothing -> False
Just (tycon, _, _)
| tycon `is_elem`
if (isBot str_val) then
binder `addIdStrictness` mkBottomStrictnessInfo
else
- case (digForLambdas body) of { (_, _, lambda_bounds, rhs) ->
+ case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
let
tys = map idType lambda_bounds
strictness = findStrictness strflags tys str_val abs_val
-- OK, it looks as if a worker is worth a try
let
- (uvars, tyvars, args, body) = digForLambdas rhs
+ (uvars, tyvars, args, body) = collectBinders rhs
body_ty = coreExprType body
in
uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result ->
import Maybes ( maybeToBool, Maybe(..), MaybeErr )
import SaLib
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( mkTyVarTy, mkFunTys, isPrimType,
- maybeDataTyCon, quantifyTy
+import Type ( mkTyVarTys, mkFunTys, isPrimType,
+ maybeAppDataTyCon, quantifyTy
)
import UniqSupply
-}
wrapper_w_hole = \ worker_id ->
mkLam tyvars args (
wrap_frag (
- mkCoTyApps (Var worker_id) (map mkTyVarTy tyvars)
+ mkCoTyApps (Var worker_id) (mkTyVarTys tyvars)
))
worker_w_hole = \ orig_body ->
| new_max_extra_args > 0 -- Check that we are prepared to add arguments
= -- this is the complicated one.
--pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) (
- case maybeDataTyCon arg_ty of
+ case maybeAppDataTyCon arg_ty of
Nothing -> -- Not a data type
panic "mk_ww_arg_processing: not datatype"
import TcMonad
import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
newDicts, tyVarsOfInst, instToId )
-import TcEnv ( tcGetGlobalTyVars, newMonoIds )
+import TcEnv ( tcGetGlobalTyVars )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals )
import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
TcTyVarSet(..), TcTyVar(..), tcInstType, zonkTcType )
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..),
- Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake,
- collectBinders )
+ Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake
+ )
import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..) )
import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
import Outputable ( pprNonOp )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
-import Type ( mkTyVarTy, isTyVarTy, mkSigmaTy, splitSigmaTy,
+import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy,
+ mkSigmaTy, splitSigmaTy,
splitRhoTy, mkForAllTy, splitForAllTy )
import Util ( panic )
\end{code}
let
(main_tyvars, main_rho) = splitForAllTy main_ty
(main_theta,main_tau) = splitRhoTy main_rho
- main_arg_tys = map mkTyVarTy main_tyvars
+ main_arg_tys = mkTyVarTys main_tyvars
in
-- Check that the specialised type is indeed an instance of
import PprType ( GenType, GenTyVar, GenClassOp )
import SpecEnv ( SpecEnv(..) )
import SrcLoc ( mkGeneratedSrcLoc )
-import Type ( mkFunTy, mkTyVarTy, mkDictTy,
+import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkForAllTy, mkSigmaTy, splitSigmaTy)
import TysWiredIn ( stringTy )
import TyVar ( GenTyVar )
buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
=
-- Make new Ids for the components of the dictionary
- mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys ->
+ mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys ->
newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
-- Make suitable bindings for the selectors
let
- tc_method_ids = map TcId method_ids
-
mk_sel sel_id method_or_dict
- = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids method_or_dict
+ = mkSelBind sel_id clas_tyvar clas_dict dict_ids method_ids method_or_dict
in
- listNF_Tc (zipWithEqual mk_sel op_sel_ids tc_method_ids) `thenNF_Tc` \ op_sel_binds ->
- listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
+ listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
+ listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
returnNF_Tc (SingleBind (
NonRecBind (
mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
= let
(op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
- op_tys = map mkTyVarTy op_tyvars
+ op_tys = mkTyVarTys op_tyvars
in
newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
import TcMonad
import Inst ( InstOrigin(..), InstanceMapper(..) )
import TcEnv ( getEnv_TyCons )
+import TcKind ( TcKind )
import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings,
maybeTyConSingleCon, isEnumerationTyCon, TyCon )
-import Type ( GenType(..), TauType(..), mkTyVarTy, applyTyCon,
+import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
getAppTyCon, getAppDataTyCon )
import TyVar ( GenTyVar )
makeDerivEqns
= tcGetEnv `thenNF_Tc` \ env ->
let
- tycons = eltsUFM (getEnv_TyCons env)
+ tycons = getEnv_TyCons env
think_about_deriving = need_deriving tycons
in
mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
= (clas, tycon, tyvars, constraints)
where
tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ???
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
data_cons = getTyConDataCons tycon
constraints = concat (map mk_constraints data_cons)
all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
- = InstInfo clas tyvars (applyTyCon tycon (map mkTyVarTy tyvars))
+ = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
theta
theta -- Blarg. This is the dfun_theta slot,
-- which is needed by buildInstanceEnv;
initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
- tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyConEnv, tcExtendClassEnv,
- tcLookupTyVar, tcLookupTyCon, tcLookupClass, tcLookupClassByKey,
+ tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar,
+
+ tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
+ tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
tcExtendGlobalValEnv, tcExtendLocalValEnv,
- tcLookupLocalValue, tcLookupLocalValueOK,
+ tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcTyVarScope, newMonoIds, newLocalIds,
+ newMonoIds, newLocalIds, newLocalId,
tcGetGlobalTyVars
) where
import TcMLoop -- for paranoia checking
import Id ( Id(..), GenId, idType, mkUserLocal )
-import TcHsSyn ( TcIdBndr(..) )
+import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) )
import TcKind ( TcKind, newKindVars, tcKindToKind, kindToTcKind )
import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars )
import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
import Type ( tyVarsOfTypes )
-import TyCon ( TyCon, getTyConKind )
+import TyCon ( TyCon, Arity(..), getTyConKind, getSynTyConArity )
import Class ( Class(..), GenClass, getClassSig )
import TcMonad
\begin{code}
data TcEnv s = TcEnv
(TyVarEnv s)
+ (TyConEnv s)
+ (ClassEnv s)
(ValueEnv Id) -- Globals
(ValueEnv (TcIdBndr s)) -- Locals
(MutableVar s (TcTyVarSet s)) -- Free type variables of locals
-- ...why mutable? see notes with tcGetGlobalTyVars
- (KindEnv s) -- Gives TcKinds of TyCons and Classes
- TyConEnv
- ClassEnv
type TyVarEnv s = UniqFM (TcKind s, TyVar)
-type TyConEnv = UniqFM TyCon
-type KindEnv s = UniqFM (TcKind s)
-type ClassEnv = UniqFM Class
+type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only
+type ClassEnv s = UniqFM (TcKind s, Class)
type ValueEnv id = UniqFM id
initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
-initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM mut emptyUFM emptyUFM emptyUFM
+initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
-getEnv_LocalIds (TcEnv _ _ ls _ _ _ _) = ls
-getEnv_TyCons (TcEnv _ _ _ _ _ ts _) = ts
-getEnv_Classes (TcEnv _ _ _ _ _ _ cs) = cs
+getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
+getEnv_TyCons (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
+getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs]
\end{code}
Making new TcTyVars, with knot tying!
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyVarScope :: [Name] -- Names of some type variables
- -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
- -> TcM s a -- Result
-
-tcTyVarScope tyvar_names thing_inside
- = newKindVars (length tyvar_names) `thenNF_Tc` \ tyvar_kinds ->
+tcTyVarScopeGivenKinds
+ :: [Name] -- Names of some type variables
+ -> [TcKind s]
+ -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
+ -> TcM s a -- Result
- fixTc (\ ~(tyvars, _) ->
- -- Ok to look at kinds, but not tyvars!
- tcExtendTyVarEnv tyvar_names (tyvar_kinds `zipLazy` tyvars) (
+tcTyVarScopeGivenKinds names kinds thing_inside
+ = fixTc (\ ~(rec_tyvars, _) ->
+ -- Ok to look at names, kinds, but not tyvars!
- -- Do the thing inside
- thing_inside tyvars `thenTc` \ result ->
+ tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ let
+ tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars))
+ in
+ tcSetEnv (TcEnv tve' tce ce gve lve gtvs)
+ (thing_inside rec_tyvars) `thenTc` \ result ->
-- Get the tyvar's Kinds from their TcKinds
- mapNF_Tc tcKindToKind tyvar_kinds `thenNF_Tc` \ tyvar_kinds' ->
+ mapNF_Tc tcKindToKind kinds `thenNF_Tc` \ kinds' ->
-- Construct the real TyVars
let
- tyvars = zipWithEqual mk_tyvar tyvar_names tyvar_kinds'
+ tyvars = zipWithEqual mk_tyvar names kinds'
mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
in
returnTc (tyvars, result)
- )) `thenTc` \ (_,result) ->
+ ) `thenTc` \ (_,result) ->
returnTc result
+
+tcTyVarScope names thing_inside
+ = newKindVars (length names) `thenNF_Tc` \ kinds ->
+ tcTyVarScopeGivenKinds names kinds thing_inside
\end{code}
The Kind, TyVar, Class and TyCon envs
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Extending the environments
+Extending the environments. Notice the uses of @zipLazy@, which makes sure
+that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
\begin{code}
-tcExtendKindEnv :: [Name] -> [TcKind s] -> TcM s r -> TcM s r
-tcExtendKindEnv names kinds scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
- let
- ke' = addListToUFM ke (names `zip` kinds)
- in
- tcSetEnv (TcEnv tve gve lve gtvs ke' tce ce) scope
-
-tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
-tcExtendTyVarEnv tyvar_names kinds_w_tyvars scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
- let
- tve' = addListToUFM tve (tyvar_names `zip` kinds_w_tyvars)
- in
- tcSetEnv (TcEnv tve' gve lve gtvs ke tce ce) scope
-
-tcExtendTyConEnv tycons scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+tcExtendTyConEnv names_w_arities tycons scope
+ = newKindVars (length names_w_arities) `thenNF_Tc` \ kinds ->
+ tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- tce' = addListToUFM_Directly tce [(getItsUnique tycon, tycon) | tycon <- tycons]
+ tce' = addListToUFM tce [ (name, (kind, arity, tycon))
+ | ((name,arity), (kind,tycon)) <- names_w_arities `zip`
+ (kinds `zipLazy` tycons)
+ ]
in
- tcSetEnv (TcEnv tve gve lve gtvs ke tce' ce) scope
+ tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
-tcExtendClassEnv classes scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
+tcExtendClassEnv names classes scope
+ = newKindVars (length names) `thenNF_Tc` \ kinds ->
+ tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- ce' = addListToUFM_Directly ce [(getItsUnique clas, clas) | clas <- classes]
+ ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes))
in
- tcSetEnv (TcEnv tve gve lve gtvs ke tce ce') scope
+ tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
\end{code}
-Looking up in the environments
+Looking up in the environments.
\begin{code}
tcLookupTyVar name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
tcLookupTyCon (WiredInTyCon tc) -- wired in tycons
- = returnNF_Tc (kindToTcKind (getTyConKind tc), tc)
+ = returnNF_Tc (kindToTcKind (getTyConKind tc), getSynTyConArity tc, tc)
tcLookupTyCon name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
- let
- tycon = lookupWithDefaultUFM tce (panic "tcLookupTyCon") name
- kind = lookupWithDefaultUFM ke (kindToTcKind (getTyConKind tycon)) name
- -- The KE will bind tycon in the current mutually-recursive set.
- -- If the KE doesn't, then the tycon is already defined, and we
- -- can safely grab the kind from the TyCon itself
- in
- returnNF_Tc (kind,tycon)
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name)
+tcLookupTyConByKey uniq
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ let
+ (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce (panic "tcLookupTyCon") uniq
+ in
+ returnNF_Tc tycon
tcLookupClass name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
- let
- clas = lookupWithDefaultUFM ce (panic "tcLookupClass") name
- (tyvar, _, _) = getClassSig clas
- kind = lookupWithDefaultUFM ke (kindToTcKind (getTyVarKind tyvar)) name
- in
- returnNF_Tc (kind,clas)
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name)
tcLookupClassByKey uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- clas = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
+ (kind, clas) = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
in
- returnNF_Tc (clas)
+ returnNF_Tc clas
\end{code}
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tcExtendGlobalValEnv ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
in
- tcSetEnv (TcEnv tve gve' lve gtvs ke tce ce) scope
+ tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
tcExtendLocalValEnv names ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let
lve' = addListToUFM lve (names `zip` ids)
in
tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv tve gve lve' gtvs' ke tce ce) scope
+ tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
\end{code}
@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
\begin{code}
tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
tcGetGlobalTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
zonkTcTyVars global_tvs `thenNF_Tc` \ global_tvs' ->
tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
\begin{code}
tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
tcLookupLocalValue name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM lve name)
+tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValueByKey uniq
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ returnNF_Tc (lookupUFM_Directly lve uniq)
+
tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
tcLookupLocalValueOK err name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
= returnNF_Tc id
tcLookupGlobalValue name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM gve def name)
where
#ifdef DEBUG
tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
tcLookupGlobalValueByKey uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
where
#ifdef DEBUG
where
no_of_names = length names
-newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdBndr s]
+newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s)
+newLocalId name ty
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (TcId (mkUserLocal name uniq ty loc))
+
+newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdOcc s]
newLocalIds names tys
= tcGetSrcLoc `thenNF_Tc` \ loc ->
tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
let
new_ids = zipWith3Equal mk_id names uniqs tys
- mk_id name uniq ty = mkUserLocal name uniq ty loc
+ mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc)
in
returnNF_Tc new_ids
\end{code}
import TcType ( TcType(..), TcMaybe(..), tcReadTyVar,
tcInstType, tcInstTcType,
tcInstTyVar, newTyVarTy, zonkTcTyVars )
+import TcKind ( TcKind )
import Class ( Class(..), getClassSig )
import Id ( Id(..), GenId, idType )
floatPrimTy, addrPrimTy, addrTy,
boolTy, charTy, stringTy, mkListTy,
mkTupleTy, mkPrimIoTy )
-import Type ( mkFunTy, mkAppTy, mkTyVarTy,
+import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
getTyVar_maybe, getFunTy_maybe,
splitForAllTy, splitRhoTy, splitSigmaTy,
isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe )
-import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, tyVarListToSet )
+import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
-- Check overloading constraints
tcSimplifyAndCheck
- (tyVarListToSet sig_tyvars')
+ (mkTyVarSet sig_tyvars')
sig_dicts lie `thenTc_`
-- If everything is ok, return the stuff unchanged, except for
-- Even if there isn't, there may be some Insts which mention the arg_tyvars,
-- but which, on simplification, don't actually need a dictionary involving
-- the tyvar. So we have to do a proper simplification right here.
- tcSimplifyRank2 (tyVarListToSet arg_tyvars')
+ tcSimplifyRank2 (mkTyVarSet arg_tyvars')
lie_arg `thenTc` \ (free_insts, inst_binds) ->
-- This HsLet binds any Insts which came out of the simplification.
let
(tyvars, rho) = splitForAllTy ty
(theta,tau) = splitRhoTy rho
- arg_tys = map mkTyVarTy tyvars
+ arg_tys = mkTyVarTys tyvars
in
-- Is it overloaded?
case theta of
newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
import TcDeriv ( tcDeriving )
-import TcEnv ( tcLookupClass, tcTyVarScope, newLocalIds )
+import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId )
import TcGRHSs ( tcGRHSsAndBinds )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcKind ( TcKind, unifyKind )
isCcallishClass, getClassBigSig,
getClassOps, getClassOpLocalType )
import CoreUtils ( escErrorMsg )
-import Id ( idType, isDefaultMethodId_maybe )
+import Id ( GenId, idType, isDefaultMethodId_maybe )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust )
import Name ( Name, getTagFromClassOpName )
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import TyCon ( derivedFor )
-import Type ( GenType(..), ThetaType(..), mkTyVarTy,
- splitSigmaTy, splitAppTy, isTyVarTy, matchTy,
+import Type ( GenType(..), ThetaType(..), mkTyVarTys,
+ splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
getTyCon_maybe, maybeBoxedPrimType )
-import TyVar ( GenTyVar, tyVarListToSet )
+import TyVar ( GenTyVar, mkTyVarSet )
import TysWiredIn ( stringTy )
import Unique ( Unique )
import Util ( panic )
-- Get the class signature
mapNF_Tc tcInstTyVar inst_tyvars `thenNF_Tc` \ inst_tyvars' ->
let
- tenv = inst_tyvars `zip` (map mkTyVarTy inst_tyvars')
+ tenv = inst_tyvars `zip` (mkTyVarTys inst_tyvars')
(class_tyvar,
super_classes, sc_sel_ids,
let
sc_theta' = super_classes `zip` (repeat inst_ty')
origin = InstanceDeclOrigin
- mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
+ mk_method sel_id = newMethodId sel_id inst_ty' origin locn
in
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
dict_and_method_binds
= dict_bind `AndMonoBinds` method_mbinds
- inst_tyvars_set' = tyVarListToSet inst_tyvars'
+ inst_tyvars_set' = mkTyVarSet inst_tyvars'
in
-- Check the overloading constraints of the methods and superclasses
tcAddErrCtxt (bindSigCtxt meth_ids) (
returnTc (const_lie `plusLIE` spec_lie, inst_binds)
\end{code}
-This function makes a default method which calls the global default method, at
+@mkMethodId@ manufactures an id for a local method.
+It's rather turgid stuff, because there are two cases:
+
+ (a) For methods with no local polymorphism, we can make an Inst of the
+ class-op selector function and a corresp InstId;
+ which is good because then other methods which call
+ this one will do so directly.
+
+ (b) For methods with local polymorphism, we can't do this. For example,
+
+ class Foo a where
+ op :: (Num b) => a -> b -> a
+
+ Here the type of the class-op-selector is
+
+ forall a b. (Foo a, Num b) => a -> b -> a
+
+ The locally defined method at (say) type Float will have type
+
+ forall b. (Num b) => Float -> b -> Float
+
+ and the one is not an instance of the other.
+
+ So for these we just make a local (non-Inst) id with a suitable type.
+
+How disgusting.
+
+\begin{code}
+newMethodId sel_id inst_ty origin loc
+ = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
+ (_:meth_theta) = sel_theta -- The local theta is all except the
+ -- first element of the context
+ in
+ case sel_tyvars of
+ -- Ah! a selector for a class op with no local polymorphism
+ -- Build an Inst for this
+ [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty]
+
+ -- Ho! a selector for a class op with local polymorphism.
+ -- Just make a suitably typed local id for this
+ (clas_tyvar:local_tyvars) ->
+ tcInstType [(clas_tyvar,inst_ty)]
+ (mkSigmaTy local_tyvars meth_theta sel_tau)
+ `thenNF_Tc` \ method_ty ->
+ newLocalId (getOccurrenceName sel_id) method_ty `thenNF_Tc` \ meth_id ->
+ returnNF_Tc (emptyLIE, meth_id)
+\end{code}
+
+The next function makes a default method which calls the global default method, at
the appropriate instance type.
See the notes under default decls in TcClassDcl.lhs.
mkHsTyLam op_tyvars (
mkHsDictLam op_dicts (
mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
- (inst_ty : map mkTyVarTy op_tyvars))
+ (inst_ty : mkTyVarTys op_tyvars))
(this_dict : op_dicts)
)))
where
-- The latter is needed just so we can return an AbsBinds wrapped
-- up inside a MonoBinds.
- newLocalIds [occ,occ] [method_tau,method_ty] `thenNF_Tc` \ new_ids ->
+ newLocalId occ method_tau `thenNF_Tc` \ local_id ->
+ newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
let
- [local_id, copy_id] = map TcId new_ids
inst_method_tyvars = inst_tyvars ++ method_tyvars
in
-- Typecheck the method
-- the Bar-ish things.
tcAddErrCtxt (methodSigCtxt op method_ty) (
tcSimplifyAndCheck
- (tyVarListToSet inst_method_tyvars)
+ (mkTyVarSet inst_method_tyvars)
(method_dicts `plusLIE` avail_insts)
lieIop
) `thenTc` \ (f_dicts, dict_binds) ->
babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
`thenTc` \ inst_ty ->
let
- maybe_tycon = case maybeDataTyCon inst_ty of
+ maybe_tycon = case maybeAppDataTyCon inst_ty of
Just (tc,_,_) -> Just tc
Nothing -> Nothing
Just tycon -> match_tycon tycon
Nothing -> match_fun
- match_tycon tycon inst_ty = case (maybeDataTyCon inst_ty) of
+ match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
Just (inst_tc,_,_) -> tycon == inst_tc
Nothing -> False
is_plain_instance inst_ty
- = case (maybeDataTyCon inst_ty) of
+ = case (maybeAppDataTyCon inst_ty) of
Just (_,tys,_) -> all isTyVarTemplateTy tys
Nothing -> case maybeUnpackFunTy inst_ty of
Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
import Pretty
import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
import SrcLoc ( SrcLoc )
-import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTy,
+import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
import TyVar ( GenTyVar )
import Unique ( Unique )
Succeeded spec_env' -> spec_env' )
where
(local_tyvars, _) = splitForAllTy (getClassOpLocalType op)
- local_tyvar_tys = map mkTyVarTy local_tyvars
+ local_tyvar_tys = mkTyVarTys local_tyvars
rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
- (map mkTyVarTy inst_tyvars))
+ (mkTyVarTys inst_tyvars))
local_tyvar_tys)
in
returnTc (class_inst_env', op_spec_envs')
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
- getEnv_TyCons, getEnv_Classes)
+ getEnv_TyCons, getEnv_Classes,
+ tcLookupLocalValueByKey, tcLookupTyConByKey )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, InstInfo )
[(Id, TypecheckedHsExpr)]), -- constant instance binds
- ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+ ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo),
-- things for the interface generator
- (UniqFM TyCon, UniqFM Class),
+ ([TyCon], [Class]),
-- environments of info from this module only
FiniteMap TyCon [(Bool, [Maybe Type])],
tycons = getEnv_TyCons final_env
classes = getEnv_Classes final_env
- local_tycons = filterUFM isLocallyDefined tycons
- local_classes = filterUFM isLocallyDefined classes
+ local_tycons = filter isLocallyDefined tycons
+ local_classes = filter isLocallyDefined classes
- exported_ids = [v | v <- eltsUFM localids,
+ exported_ids = [v | v <- localids,
isExported v && not (isDataCon v) && not (isMethodSelId v)]
in
-- Backsubstitution. Monomorphic top-level decls may have
\begin{code}
checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
checkTopLevelIds mod final_env
- = if (mod /= SLIT("Main")) then
- returnTc ()
- else
- case (lookupUFM_Directly localids mainIdKey,
- lookupUFM_Directly localids mainPrimIOIdKey) of
+ | mod /= SLIT("Main")
+ = returnTc ()
+
+ | otherwise
+ = tcSetEnv final_env (
+ tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
+ tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
+ tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
+
+ case (maybe_main, maybe_prim) of
(Just main, Nothing) -> tcAddErrCtxt mainCtxt $
- unifyTauTy ty_main (idType main)
+ unifyTauTy (applyTyCon io_tc [unitTy])
+ (idType main)
+
(Nothing, Just prim) -> tcAddErrCtxt primCtxt $
- unifyTauTy ty_prim (idType prim)
+ unifyTauTy (mkPrimIoTy unitTy)
+ (idType prim)
+
(Just _ , Just _ ) -> failTc mainBothIdErr
(Nothing, Nothing) -> failTc mainNoneIdErr
- where
- localids = getEnv_LocalIds final_env
- tycons = getEnv_TyCons final_env
-
- io_tc = lookupWithDefaultUFM_Directly tycons io_panic iOTyConKey
- io_panic = panic "TcModule: type IO not in scope"
-
- ty_main = applyTyCon io_tc [unitTy]
- ty_prim = mkPrimIoTy unitTy
-
+ )
mainCtxt sty
= ppStr "main should have type IO ()"
import TcMonad
import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
- tcExtendTyVarEnv, tcTyVarScope
+ tcTyVarScope, tcTyVarScopeGivenKinds
)
import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
mkTcArrowKind, unifyKind, newKindVar,
import PrelInfo ( mkListTy, mkTupleTy )
import Type ( mkDictTy )
import Class ( cCallishClassKeys )
+import TyCon ( TyCon, Arity(..) )
import Unique ( Unique )
import Name ( Name(..), getNameShortName, isTyConName, getSynNameArity )
import PprStyle
tcMonoTypeKind (MonoTyApp name tys)
= mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
- tc_mono_name name `thenNF_Tc` \ (fun_kind, fun_ty) ->
+ tc_mono_name name `thenNF_Tc` \ (fun_kind, maybe_arity, fun_ty) ->
newKindVar `thenNF_Tc` \ result_kind ->
unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
-- Check for saturated application in the special case of
- -- type synoyms. Here the renamer has kindly attached the
- -- arity to the Name.
- synArityCheck name (length tys) `thenTc_`
+ -- type synoyms.
+ (case maybe_arity of
+ Just arity | arity /= n_args -> failTc (err arity)
+ other -> returnTc ()
+ ) `thenTc_`
returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
+ where
+ err arity = arityErr "Type synonym constructor" name arity n_args
+ n_args = length tys
-- for unfoldings only:
tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
- = tcExtendTyVarEnv tyvar_names (tc_kinds `zip` tyvars) (
+ = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
unifyKind kind mkTcTypeKind `thenTc_`
returnTc (mkTcTypeKind, ty')
)
where
- (tyvar_names, kinds) = unzip tyvars_w_kinds
- tyvars = zipWithEqual mk_tyvar tyvar_names kinds
+ (names, kinds) = unzip tyvars_w_kinds
tc_kinds = map kindToTcKind kinds
- mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
-- for unfoldings only:
tcMonoTypeKind (MonoDictTy class_name ty)
returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
-tc_mono_name :: Name -> NF_TcM s (TcKind s, Type)
+tc_mono_name :: Name -> NF_TcM s (TcKind s, Maybe Arity, Type)
tc_mono_name name@(Short _ _) -- Must be a type variable
= tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- returnNF_Tc (kind, mkTyVarTy tyvar)
+ returnNF_Tc (kind, Nothing, mkTyVarTy tyvar)
tc_mono_name name | isTyConName name -- Must be a type constructor
- = tcLookupTyCon name `thenNF_Tc` \ (kind,tycon) ->
- returnNF_Tc (kind, mkTyConTy tycon)
+ = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
+ returnNF_Tc (kind, maybe_arity, mkTyConTy tycon)
tc_mono_name name -- Renamer should have got it right
= panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
)
\end{code}
-Auxilliary functions
-~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-synArityCheck :: Name -> Int -> TcM s ()
-synArityCheck name n_args
- = case getSynNameArity name of
- Just arity | arity /= n_args -> failTc (err arity)
- other -> returnTc ()
- where
- err arity = arityErr "Type synonym constructor" name arity n_args
-\end{code}
-
Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
import Inst ( InstanceMapper(..) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
- tcExtendGlobalValEnv, tcExtendKindEnv,
+ tcExtendGlobalValEnv,
tcTyVarScope, tcGetEnv )
import TcKind ( TcKind, newKindVars )
import TcTyDecls ( tcTyDecl )
\begin{code}
tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
tcGroup inst_mapper decls
- = fixTc ( \ ~(tycons,classes,_) ->
+ = pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
+ -- TIE THE KNOT
+ fixTc ( \ ~(tycons,classes,_) ->
-- EXTEND TYPE AND CLASS ENVIRONMENTS
-- including their data constructors and class operations
- tcExtendTyConEnv tycons $
- tcExtendClassEnv classes $
+ -- NB: it's important that the tycons and classes come back in just
+ -- the same order from this fix as from get_binders, so that these
+ -- extend-env things work properly. A bit UGH-ish.
+ tcExtendTyConEnv tycon_names_w_arities tycons $
+ tcExtendClassEnv class_names classes $
tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $
tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
-- DEAL WITH TYPE VARIABLES
tcTyVarScope tyvar_names ( \ tyvars ->
- -- MANUFACTURE NEW KINDS, AND EXTEND KIND ENV
- newKindVars (length tycon_names) `thenNF_Tc` \ tycon_kinds ->
- newKindVars (length class_names) `thenNF_Tc` \ class_kinds ->
- tcExtendKindEnv tycon_names tycon_kinds $
- tcExtendKindEnv class_names class_kinds $
-
-
-- DEAL WITH THE DEFINITIONS THEMSELVES
foldBag combine (tcDecl inst_mapper)
(returnTc (emptyBag, emptyBag))
returnTc final_env
where
- (tyvar_names, tycon_names, class_names) = get_binders decls
+ (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
combine do_a do_b
= do_a `thenTc` \ (a1,a2) ->
set_to_bag set = listToBag (uniqSetToList set)
\end{code}
+
+get_binders
+~~~~~~~~~~~
Extract *binding* names from type and class decls. Type variables are
bound in type, data, newtype and class declarations and the polytypes
in the class op sigs.
\begin{code}
get_binders :: Bag Decl
- -> ([Name], -- TyVars; no dups
- [Name], -- Tycons; no dups
- [Name]) -- Classes; no dups
+ -> ([Name], -- TyVars; no dups
+ [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
+ [Name]) -- Classes; no dups
get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
where
= (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
- = (listToBag tyvars, unitBag name, emptyBag)
+ = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
- = (listToBag tyvars, unitBag name, emptyBag)
+ = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
get_binders1 (TyD (TySynonym name tyvars _ _))
- = (listToBag tyvars, unitBag name, emptyBag)
+ = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
= (unitBag tyvar `unionBags` sigs_tvs sigs,
emptyBag, unitBag name)
--- ToDo: will this duplicate the class tyvar
-
sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
where
sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
- pty_tvs (HsForAllTy tvs _ _) = listToBag tvs
+ pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
\end{code}
tcAddErrCtxt (tySynCtxt tycon_name) $
-- Look up the pieces
- tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, rec_tycon) ->
+ tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
-- Look at the rhs
tcAddErrCtxt (tyDataCtxt tycon_name) $
-- Lookup the pieces
- tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, rec_tycon) ->
+ tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
tc_derivs derivings `thenNF_Tc` \ derived_classes ->
do env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (SynTy tycon tys' ty')
- do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
- do env res `thenNF_Tc` \ res' ->
- returnNF_Tc (FunTy arg' res' usage)
+ do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
+ do env res `thenNF_Tc` \ res' ->
+ returnNF_Tc (FunTy arg' res' usage)
- do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
- do env arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (AppTy fun' arg')
+ do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
+ do env arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (AppTy fun' arg')
do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (DictTy clas ty' usage)
[(Id, TypecheckedHsExpr)] -- constant instance binds
),
- ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+ ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo),
-- things for the interface generator
- (UniqFM TyCon, UniqFM Class),
+ ([TyCon], [Class]),
-- environments of info from this module only
FiniteMap TyCon [(Bool, [Maybe Type])],
growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
GenTyVarSet(..), TyVarSet(..),
- emptyTyVarSet, singletonTyVarSet, unionTyVarSets, tyVarListToSet,
- tyVarSetToList, elementOfTyVarSet, minusTyVarSet, isEmptyTyVarSet
+ emptyTyVarSet, singletonTyVarSet, unionTyVarSets,
+ unionManyTyVarSets, intersectTyVarSets, mkTyVarSet,
+ tyVarSetToList, elementOfTyVarSet, minusTyVarSet,
+ isEmptyTyVarSet
) where
CHK_Ubiq() -- debugging consistency check
import Kind ( Kind, mkBoxedTypeKind )
-- others
-import UniqSet ( uniqSetToList, emptyUniqSet, singletonUniqSet, minusUniqSet,
- unionUniqSets, elementOfUniqSet, isEmptyUniqSet, mkUniqSet,
- UniqSet(..) )
+import UniqSet -- nearly all of it
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
- plusUFM, sizeUFM, UniqFM )
+ plusUFM, sizeUFM, UniqFM
+ )
import Maybes ( Maybe(..) )
import NameTypes ( ShortName )
import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr )
type TyVarSet = UniqSet TyVar
emptyTyVarSet :: GenTyVarSet flexi
+intersectTyVarSets:: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
unionTyVarSets :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
+unionManyTyVarSets:: [GenTyVarSet flexi] -> GenTyVarSet flexi
tyVarSetToList :: GenTyVarSet flexi -> [GenTyVar flexi]
singletonTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi
elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool
minusTyVarSet :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
isEmptyTyVarSet :: GenTyVarSet flexi -> Bool
-tyVarListToSet :: [GenTyVar flexi] -> GenTyVarSet flexi
+mkTyVarSet :: [GenTyVar flexi] -> GenTyVarSet flexi
emptyTyVarSet = emptyUniqSet
singletonTyVarSet = singletonUniqSet
+intersectTyVarSets= intersectUniqSets
unionTyVarSets = unionUniqSets
+unionManyTyVarSets= unionManyUniqSets
tyVarSetToList = uniqSetToList
elementOfTyVarSet = elementOfUniqSet
minusTyVarSet = minusUniqSet
isEmptyTyVarSet = isEmptyUniqSet
-tyVarListToSet = mkUniqSet
+mkTyVarSet = mkUniqSet
\end{code}
Instance delarations
module Type (
GenType(..), Type(..), TauType(..),
- mkTyVarTy, getTyVar, getTyVar_maybe, isTyVarTy,
+ mkTyVarTy, mkTyVarTys,
+ getTyVar, getTyVar_maybe, isTyVarTy,
mkAppTy, mkAppTys, splitAppTy,
mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe,
mkTyConTy, getTyCon_maybe, applyTyCon,
Simple construction and analysis functions
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-mkTyVarTy :: t -> GenType t u
-mkTyVarTy = TyVarTy
--- could we use something for (map mkTyVarTy blahs) ?? WDP
+mkTyVarTy :: t -> GenType t u
+mkTyVarTys :: [t] -> [GenType t y]
+mkTyVarTy = TyVarTy
+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
getTyVar :: String -> GenType t u -> t
-getTyVar msg (TyVarTy tv) = tv
-getTyVar msg (SynTy _ _ t) = getTyVar msg t
-getTyVar msg other = error ("getTyVar" ++ msg)
+getTyVar msg (TyVarTy tv) = tv
+getTyVar msg (SynTy _ _ t) = getTyVar msg t
+getTyVar msg other = panic ("getTyVar: " ++ msg)
getTyVar_maybe :: GenType t u -> Maybe t
-getTyVar_maybe (TyVarTy tv) = Just tv
+getTyVar_maybe (TyVarTy tv) = Just tv
getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
-getTyVar_maybe other = Nothing
+getTyVar_maybe other = Nothing
isTyVarTy :: GenType t u -> Bool
isTyVarTy (TyVarTy tv) = True
InstancePragmas
)
import Id ( StrictnessMark, GenId, Id(..) )
-import IdInfo ( IdInfo, OptIdInfo(..), DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
+import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
import Kind ( Kind )
import Literal ( Literal )
import Maybes ( MaybeErr )
-- used everywhere and (b) the compiler doesn't lose much
-- optimisation-wise by not seeing their pragma-gunk.
+data ArityInfo
data Bag a
data BinderInfo
data ClassOpPragmas a
projects / ghc-hetmet.git / commitdiff