#include "HsVersions.h"
import CoreSyn
-
-import DynFlags ( FloatOutSwitches(..) )
+import CoreMonad ( FloatOutSwitches(..) )
import CoreUtils ( exprType, mkPiTypes )
import CoreArity ( exprBotStrictness_maybe )
import CoreFVs -- all of it
-- abs_vars = tvars only: return True if e is trivial,
-- but False for anything bigger
-- abs_vars = [x] (an Id): return True for trivial, or an application (f x)
--- but False for (f x x)
+-- but False for (f x x)
--
-- One big goal is that floating should be idempotent. Eg if
-- we replace e with (lvl79 x y) and then run FloatOut again, don't want
notWorthFloating e abs_vars
= go e (count isId abs_vars)
where
- go (_, AnnVar {}) n = n == 0
- go (_, AnnLit {}) n = n == 0
+ go (_, AnnVar {}) n = n >= 0
+ go (_, AnnLit {}) n = n >= 0
go (_, AnnCast e _) n = go e n
go (_, AnnApp e arg) n
| (_, AnnType {}) <- arg = go e n
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | isTyVar bndr -- Don't do anything for TyVar binders
+ | isTyCoVar bndr -- Don't do anything for TyVar binders
-- (simplifier gets rid of them pronto)
= do rhs' <- lvlExpr ctxt_lvl env rhs
return (NonRec (TB bndr ctxt_lvl) rhs', env)
abs_vars = abstractVars dest_lvl env bind_fvs
----------------------------------------------------
--- Three help functons for the type-abstraction case
+-- Three help functions for the type-abstraction case
lvlFloatRhs :: [CoreBndr] -> Level -> LevelEnv -> CoreExprWithFVs
-> UniqSM (Expr (TaggedBndr Level))
(False, True) -> False
_ -> v1 <= v2 -- Same family
- is_tv v = isTyVar v && not (isCoVar v)
+ is_tv v = isTyCoVar v && not (isCoVar v)
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
- zap v | isId v = WARN( isInlineRule (idUnfolding v) ||
+ zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo