simplIdWantsToBeINLINEd,
- singleConstructorType, typeOkForCase
+ singleConstructorType, typeOkForCase,
+
+ substSpecEnvRhs
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) )
-import Id ( idType, isBottomingId, mkSysLocal,
+import MkId ( mkSysLocal )
+import Id ( idType, isBottomingId, getIdArity,
addInlinePragma, addIdDemandInfo,
idWantsToBeINLINEd, dataConArgTys, Id,
- getIdArity,
+ lookupIdEnv, delOneFromIdEnv
)
import IdInfo ( ArityInfo(..), DemandInfo )
import Maybes ( maybeToBool )
import PrimOp ( primOpIsCheap )
import SimplEnv
import SimplMonad
-import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe,
- splitAlgTyConApp_maybe, Type
+import Type ( tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, getTyVar_maybe,
+ splitAlgTyConApp_maybe, instantiateTy, Type
)
import TyCon ( isDataTyCon )
-import TyVar ( elementOfTyVarSet )
+import TyVar ( mkTyVarSet, intersectTyVarSets, elementOfTyVarSet, tyVarSetToList,
+ delFromTyVarEnv
+ )
import SrcLoc ( noSrcLoc )
import Util ( isIn, zipWithEqual, panic, assertPanic )
floatExposesHNF
:: Bool -- Float let(rec)s out of rhs
-> Bool -- Float cheap primops out of rhs
- -> Bool -- OK to duplicate code
-> 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:
\begin{code}
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)
-- 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