import AnnCoreSyn
import CoreSyn
-import CoreUtils ( coreExprType, manifestlyWHNF, manifestlyBottom )
+import CoreUtils ( coreExprType )
+import CoreUnfold ( FormSummary, whnfOrBottom, mkFormSummary )
import FreeVars -- all of it
-import Id ( idType, mkSysLocal, toplevelishId,
+import Id ( idType, mkSysLocal,
nullIdEnv, addOneToIdEnv, growIdEnvList,
unionManyIdSets, minusIdSet, mkIdSet,
- idSetToList,
+ idSetToList, SYN_IE(Id),
lookupIdEnv, SYN_IE(IdEnv)
)
-import Pretty ( ppStr, ppBesides, ppChar, ppInt )
-import SrcLoc ( mkUnknownSrcLoc )
-import Type ( isPrimType, mkTyVarTys, mkForAllTys )
+import Pretty ( ptext, hcat, char, int )
+import SrcLoc ( noSrcLoc )
+import Type ( isPrimType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, SYN_IE(Type) )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
growTyVarEnvList, lookupTyVarEnv,
- tyVarSetToList,
- SYN_IE(TyVarEnv),
- unionManyTyVarSets
+ tyVarSetToList,
+ SYN_IE(TyVarEnv), SYN_IE(TyVar),
+ unionManyTyVarSets, unionTyVarSets
)
import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
)
import Usage ( SYN_IE(UVar) )
import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
isLeakFreeType x y = False -- safe option; ToDo
\end{code}
unTopify lvl = lvl
instance Outputable Level where
- ppr sty Top = ppStr "<Top>"
- ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
+ ppr sty Top = ptext SLIT("<Top>")
+ ppr sty (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
\end{code}
%************************************************************************
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (Coerce c ty expr')
+-- We don't split adjacent lambdas. That is, given
+-- \x y -> (x+1,y)
+-- we don't float to give
+-- \x -> let v = x+y in \y -> (v,y)
+-- Why not? Because partial applications are fairly rare, and splitting
+-- lambdas makes them more expensive.
+
lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
- = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
- returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
+ = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
+ returnLvl (foldr (Lam . ValBinder) body' lvld_args)
where
- incd_lvl = incMajorLvl ctxt_lvl
- new_venv = growIdEnvList venv [(arg,incd_lvl)]
+ incd_lvl = incMajorLvl ctxt_lvl
+ (args, body) = annCollectValBinders rhs
+ lvld_args = [(a,incd_lvl) | a <- (arg:args)]
+ new_venv = growIdEnvList venv lvld_args
+
+-- We don't need to play such tricks for type lambdas, because
+-- they don't get annotated
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
- = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
- returnLvl (Lam (TyBinder tyvar) e')
+lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
+ = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' ->
+ returnLvl (Lam (TyBinder tyvar) body')
where
- incd_lvl = incMinorLvl ctxt_lvl
- new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
+ 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"
offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
- manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
+ manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
maybe_unTopify lvl = lvl
| rhs' <- rhss' -- mkCoLet* requires Core...
]
- poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss
+ poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
+ poly_var_rhss
in
returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
fvs = unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
+ `unionTyVarSets`
+ tyVarsOfTypes tys
+ -- Why the "tyVarsOfTypes" part? Consider this:
+ -- /\a -> letrec x::a = x in E
+ -- Now, there are no explicit free type variables in the RHS of x,
+ -- but nevertheless "a" is free in its definition. So we add in
+ -- the free tyvars of the types of the binders.
+ -- This actually happened in the defn of errorIO in IOBase.lhs:
+ -- errorIO (ST io) = case (errorIO# io) of
+ -- _ -> bottom
+ -- where
+ -- bottom = bottom -- Never evaluated
+ -- I don't think this can every happen for non-recursive bindings.
+
fv_list = idSetToList fvs
tv_list = tyVarSetToList tfvs
| otherwise = -- No point in adding a fresh let-binding for a WHNF, because
-- floating it isn't beneficial enough.
isWorthFloatingExpr expr &&
- not (manifestlyWHNF expr || manifestlyBottom expr)
+ not (whnfOrBottom expr)
********** -}
isWorthFloatingExpr :: CoreExpr -> Bool
canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
-valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
+valSuggestsLeakFree expr = whnfOrBottom expr
\end{code}
idLevel venv v
= case lookupIdEnv venv v of
Just level -> level
- Nothing -> ASSERT(toplevelishId v)
- tOP_LEVEL
+ Nothing -> tOP_LEVEL
tyvarLevel :: TyVarEnv Level -> TyVar -> Level
tyvarLevel tenv tyvar
Nothing -> tOP_LEVEL
\end{code}
+\begin{code}
+annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
+ = (arg:args, body)
+ where
+ (args, body) = annCollectValBinders rhs
+
+annCollectValBinders body
+ = ([], body)
+\end{code}
+
%************************************************************************
%* *
\subsection{Free-To-Level Monad}
newLvlVar :: Type -> LvlM Id
newLvlVar ty us
- = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
+ = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc
\end{code}
projects / ghc-hetmet.git / blobdiff