\section[SimplUtils]{The simplifier utilities}
\begin{code}
-#include "HsVersions.h"
-
module SimplUtils (
+ newId, newIds,
+
floatExposesHNF,
etaCoreExpr, mkRhsTyLam,
simplIdWantsToBeINLINEd,
- singleConstructorType, typeOkForCase
+ singleConstructorType, typeOkForCase,
+
+ substSpecEnvRhs
) where
-IMP_Ubiq(){-uitous-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(SmplLoop) -- paranoia checking
-#endif
+#include "HsVersions.h"
import BinderInfo
import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) )
-import Id ( idType, isBottomingId, addInlinePragma, addIdDemandInfo,
- idWantsToBeINLINEd, dataConArgTys, SYN_IE(Id),
- getIdArity, GenId{-instance Eq-}
+import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) )
+import MkId ( mkSysLocal )
+import Id ( idType, isBottomingId, getIdArity,
+ addInlinePragma, addIdDemandInfo,
+ idWantsToBeINLINEd, dataConArgTys, Id,
+ lookupIdEnv, delOneFromIdEnv
)
import IdInfo ( ArityInfo(..), DemandInfo )
import Maybes ( maybeToBool )
import PrimOp ( primOpIsCheap )
import SimplEnv
import SimplMonad
-import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, isPrimType, getTyVar_maybe,
- maybeAppDataTyConExpandingDicts, SYN_IE(Type)
+import Type ( tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, getTyVar_maybe,
+ splitAlgTyConApp_maybe, instantiateTy, Type
)
import TyCon ( isDataTyCon )
-import TyVar ( elementOfTyVarSet,
- GenTyVar{-instance Eq-} )
-import Util ( isIn, panic, assertPanic )
+import TyVar ( mkTyVarSet, intersectTyVarSets, elementOfTyVarSet, tyVarSetToList,
+ delFromTyVarEnv
+ )
+import SrcLoc ( noSrcLoc )
+import Util ( isIn, zipWithEqual, panic, assertPanic )
+
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{New ids}
+%* *
+%************************************************************************
+\begin{code}
+newId :: Type -> SmplM Id
+newId ty
+ = getUniqueSmpl `thenSmpl` \ uniq ->
+ returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
+
+newIds :: [Type] -> SmplM [Id]
+newIds tys
+ = getUniquesSmpl (length tys) `thenSmpl` \ uniqs ->
+ returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
+ where
+ mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
\end{code}
-Floating
-~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Floating}
+%* *
+%************************************************************************
+
The function @floatExposesHNF@ tells whether let/case floating will
expose a head normal form. It is passed booleans indicating the
desired strategy.
floatExposesHNF
:: Bool -- Float let(rec)s out of rhs
-> Bool -- Float cheap primops out of rhs
- -> Bool -- OK to duplicate code
- -> GenCoreExpr bdr Id tyvar uvar
+ -> GenCoreExpr bdr Id flexi
-> Bool
-floatExposesHNF float_lets float_primops ok_to_dup rhs
+floatExposesHNF float_lets float_primops rhs
= try rhs
where
try (Case (Prim _ _) (PrimAlts alts deflt) )
- | float_primops && (null alts || ok_to_dup)
+ | float_primops && null alts
= or (try_deflt deflt : map try_alt alts)
try (Let bind body) | float_lets = try body
mkRhsTyLam tyvars body
= go (\x -> x) body
where
- tyvar_tys = mkTyVarTys tyvars
+ main_tyvar_set = mkTyVarSet tyvars
go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
= go (fn . Let bind) body
go fn (Let bind@(NonRec var rhs) body)
- = mk_poly var `thenSmpl` \ (var', rhs') ->
+ = mk_poly tyvars_here var_ty `thenSmpl` \ (var', rhs') ->
go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body')
+ returnSmpl (Let (NonRec var' (mkTyLam tyvars_here (fn rhs))) body')
+ where
+ tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfType var_ty)
+ var_ty = idType var
go fn (Let (Rec prs) body)
- = mapAndUnzipSmpl mk_poly vars `thenSmpl` \ (vars', rhss') ->
+ = mapAndUnzipSmpl (mk_poly tyvars_here) var_tys `thenSmpl` \ (vars', rhss') ->
let
gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
in
go gn body `thenSmpl` \ body' ->
- returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body')
+ returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars_here (gn rhs) | rhs <- rhss])) body')
where
(vars,rhss) = unzip prs
+ tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfTypes var_tys)
+ var_tys = map idType vars
go fn body = returnSmpl (mkTyLam tyvars (fn body))
- mk_poly var
- = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id ->
- returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys)
+ mk_poly tyvars_here var_ty
+ = newId (mkForAllTys tyvars_here var_ty) `thenSmpl` \ poly_id ->
+ returnSmpl (poly_id, mkTyApp (Var poly_id) (mkTyVarTys tyvars_here))
mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
-- The addInlinePragma is really important! If we don't say
residual_ok (App fun arg)
| arg `mentions` bndr = False
| otherwise = residual_ok fun
- residual_ok (Coerce coercion ty body)
- | TyArg ty `mentions` bndr = False
- | otherwise = residual_ok body
+ residual_ok (Note (Coerce to_ty from_ty) body)
+ | TyArg to_ty `mentions` bndr
+ || TyArg from_ty `mentions` bndr = False
+ | otherwise = residual_ok body
residual_ok other = False -- Safe answer
-- This last clause may seem conservative, but consider:
100, to represent "infinity", which is a bit of a hack.
\begin{code}
-etaExpandCount :: GenCoreExpr bdr Id tyvar uvar
+etaExpandCount :: GenCoreExpr bdr Id flexi
-> Int -- Number of extra args you can safely abstract
etaExpandCount (Lam (ValBinder _) body)
-- Case with non-whnf scrutinee
-----------------------------
-eta_fun :: GenCoreExpr bdr Id tv uv -- The function
+eta_fun :: GenCoreExpr bdr Id flexi -- The function
-> Int -- How many args it can safely be applied to
eta_fun (App fun arg) | notValArg arg = eta_fun fun
where op is a cheap primitive operator
\begin{code}
-manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool
+manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
-manifestlyCheap (Var _) = True
-manifestlyCheap (Lit _) = True
-manifestlyCheap (Con _ _) = True
-manifestlyCheap (SCC _ e) = manifestlyCheap e
-manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
-manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
-manifestlyCheap (Prim op _) = primOpIsCheap op
+manifestlyCheap (Var _) = True
+manifestlyCheap (Lit _) = True
+manifestlyCheap (Con _ _) = True
+manifestlyCheap (Note _ e) = manifestlyCheap e
+manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
+manifestlyCheap (Prim op _) = primOpIsCheap op
manifestlyCheap (Let bind body)
= manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
= manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
manifestlyCheap other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
+ = case (collectArgs other_expr) of { (fun, _, vargs) ->
case fun of
Var f | isBottomingId f -> True -- Application of a function which
singleConstructorType :: Type -> Bool
singleConstructorType ty
- = case (maybeAppDataTyConExpandingDicts ty) of
+ = case (splitAlgTyConApp_maybe ty) of
Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
other -> False
typeOkForCase :: Type -> Bool
typeOkForCase ty
- = case (maybeAppDataTyConExpandingDicts ty) of
+ = case (splitAlgTyConApp_maybe ty) of
Just (tycon, ty_args, []) -> False
Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
other -> False
-- currently handle. (ToDo: when return-in-heap is universal we
-- don't need to worry about this.)
\end{code}
+
+
+
+substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
+It exploits the known structure of a SpecEnv's RHS to have fewer
+equations.
+
+\begin{code}
+substSpecEnvRhs te ve rhs
+ = go te ve rhs
+ where
+ go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
+ go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
+ Just (SubstVar v') -> VarArg v'
+ Just (SubstLit l) -> LitArg l
+ Nothing -> VarArg v)
+ go te ve (Var v) = case lookupIdEnv ve v of
+ Just (SubstVar v') -> Var v'
+ Just (SubstLit l) -> Lit l
+ Nothing -> Var v
+
+ -- These equations are a bit half baked, because
+ -- they don't deal properly wih capture.
+ -- But I'm sure it'll never matter... sigh.
+ go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
+ where
+ te' = delFromTyVarEnv te tyvar
+
+ go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
+ where
+ ve' = delOneFromIdEnv ve v
+\end{code}
projects / ghc-hetmet.git / blobdiff