#include "HsVersions.h"
-import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
+import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
-- Ensure that the argument of DataToTagOp is evaluated
eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
eval_data2tag_arg app@(fun `App` arg)
- | exprIsValue arg -- Includes nullary constructors
+ | exprIsHNF arg -- Includes nullary constructors
= returnUs (emptyFloats, app) -- The arg is evaluated
| otherwise -- Arg not evaluated, so evaluate it
= newVar (exprType arg) `thenUs` \ arg_id ->
CoreExpr) -- Final Rhs
floatRhs top_lvl is_rec bndr (floats, rhs)
- | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
+ | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
allLazy top_lvl is_rec floats -- at top level
= -- Why the test for allLazy?
-- v = f (x `divInt#` y)
= let -- Don't make a case for a value binding,
-- even if it's strict. Otherwise we get
-- case (\x -> e) of ...!
- float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
+ float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
| otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
in
returnUs (addFloat floats float, evald_bndr)
| otherwise
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
- if exprIsValue rhs' then evald_bndr else bndr)
+ if exprIsHNF rhs' then evald_bndr else bndr)
where
evald_bndr = bndr `setIdUnfolding` evaldUnfolding
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConWorkId, dataConTag )
import BasicTypes ( Activation )
-import VarSet
import FastString
import Outputable
\end{code}
| CoreUnfolding -- An unfolding with redundant cached information
CoreExpr -- Template; binder-info is correct
Bool -- True <=> top level binding
- Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
+ Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
-- this variable
Bool -- True <=> doesn't waste (much) work to expand inside an inlining
-- Basically it's exprIsCheap
import CoreSyn
import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseExpr )
-import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
+import CoreUtils ( exprIsHNF, exprIsCheap, exprIsTrivial )
import Id ( Id, idType, isId,
idUnfolding, globalIdDetails
)
= CoreUnfolding (occurAnalyseExpr expr)
top_lvl
- (exprIsValue expr)
+ (exprIsHNF expr)
-- Already evaluated
(exprIsCheap expr)
-- Properties of expressions
exprType, coreAltType,
exprIsDupable, exprIsTrivial, exprIsCheap,
- exprIsValue,exprOkForSpeculation, exprIsBig,
+ exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
\end{code}
-@exprIsValue@ returns true for expressions that are certainly *already*
+@exprIsHNF@ returns true for expressions that are certainly *already*
evaluated to *head* normal form. This is used to decide whether it's ok
to change
type must be ok-for-speculation (or trivial).
\begin{code}
-exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
-exprIsValue (Var v) -- NB: There are no value args at this point
+exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
+exprIsHNF (Var v) -- NB: There are no value args at this point
= isDataConWorkId v -- Catches nullary constructors,
-- so that [] and () are values, for example
|| idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-exprIsValue (Lit l) = True
-exprIsValue (Type ty) = True -- Types are honorary Values;
+exprIsHNF (Lit l) = True
+exprIsHNF (Type ty) = True -- Types are honorary Values;
-- we don't mind copying them
-exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
-exprIsValue (Note _ e) = exprIsValue e
-exprIsValue (App e (Type _)) = exprIsValue e
-exprIsValue (App e a) = app_is_value e [a]
-exprIsValue other = False
+exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
+exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (App e (Type _)) = exprIsHNF e
+exprIsHNF (App e a) = app_is_value e [a]
+exprIsHNF other = False
-- There is at least one value argument
app_is_value (Var fun) args
-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
--
--
--- This is a bit like CoreUtils.exprIsValue, with the following differences:
+-- This is a bit like CoreUtils.exprIsHNF, with the following differences:
-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
--
-- b) (C x xs), where C is a contructors is updatable if the application is
import DynFlags ( DynFlags, DynFlag(..) )
import CoreLint ( showPass, endPass )
import CoreSyn
-import CoreUtils ( exprIsValue )
+import CoreUtils ( exprIsHNF )
import Id ( Id, setIdCprInfo, idCprInfo, idArity,
isBottomingId, idDemandInfo, isImplicitId )
import IdInfo ( CprInfo(..) )
Fun _ -> idArity bndr >= n_fun_tys absval
-- Enough visible lambdas
- Tuple -> exprIsValue rhs || isStrict (idDemandInfo bndr)
+ Tuple -> exprIsHNF rhs || isStrict (idDemandInfo bndr)
-- If the rhs is a value, and returns a constructed product,
-- it will be inlined at usage sites, so we give it a Tuple absval
-- If it isn't a value, we won't inline it (code/work dup worries), so
import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
-import CoreUtils ( exprIsValue, exprIsDupable )
+import CoreUtils ( exprIsHNF, exprIsDupable )
import CoreLint ( showPass, endPass )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
import Id ( isOneShotBndr )
-- boxing constructor into it, else we box it every time which is very bad
-- news indeed.
-noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float right back out again...
+noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again...
is_one_shot b = isId b && isOneShotBndr b
\end{code}
#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( mkSCC, exprIsValue, exprIsTrivial )
+import CoreUtils ( mkSCC, exprIsHNF, exprIsTrivial )
import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
import ErrUtils ( dumpIfSet_dyn )
-- bindings just after the '='. And some of them might (correctly)
-- be strict even though the 'let f' is lazy, because f, being a value,
-- gets its demand-info zapped by the simplifier.
- if exprIsValue arg' || exprIsTrivial arg' then
+ if exprIsHNF arg' || exprIsTrivial arg' then
(fsa, floats, arg')
else
case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
import CoreFVs ( exprFreeVars )
import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
- findDefault, exprOkForSpeculation, exprIsValue
+ findDefault, exprOkForSpeculation, exprIsHNF
)
import Id ( idType, isDataConWorkId, idOccInfo, isDictId, idArity,
mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
-- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
-- so substituting rhs inside a lambda doesn't change the occ info.
- -- Sadly, not quite the same as exprIsValue.
+ -- Sadly, not quite the same as exprIsHNF.
canInlineInLam (Var x) = occ_info_ok (idOccInfo x)
canInlineInLam (Lit l) = True
canInlineInLam (Type ty) = True
ok_fun fun = exprIsTrivial fun
&& not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
- && (exprIsValue fun || all ok_lam bndrs)
+ && (exprIsHNF fun || all ok_lam bndrs)
ok_lam v = isTyVar v || isDictId v
- -- The exprIsValue is because eta reduction is not
+ -- The exprIsHNF is because eta reduction is not
-- valid in general: \x. bot /= bot
-- So we need to be sure that the "fun" is a value.
--
-- x
-- This particular example shows up in default methods for
-- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsValue scrut -- It's already evaluated
+ || exprIsHNF scrut -- It's already evaluated
|| var_demanded_later scrut -- It'll be demanded later
-- || not opt_SimplPedanticBottoms) -- Or we don't care!
import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
- exprType, exprIsValue,
+ exprType, exprIsHNF,
exprOkForSpeculation, exprArity,
mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
)
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
completeLazyBind env1 top_lvl bndr bndr2 rhs2
- else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+ else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then
-- WARNING: long dodgy argument coming up
-- WANTED: a better way to do this
--
- -- We can't use "exprIsCheap" instead of exprIsValue,
+ -- We can't use "exprIsCheap" instead of exprIsHNF,
-- because that causes a strictness bug.
-- x = let y* = E in case (scc y) of { T -> F; F -> T}
-- The case expression is 'cheap', but it's wrong to transform to
-- y* = E; x = case (scc y) of {...}
-- Either we must be careful not to float demanded non-values, or
- -- we must use exprIsValue for the test, which ensures that the
- -- thing is non-strict. So exprIsValue => bindings are non-strict
+ -- we must use exprIsHNF for the test, which ensures that the
+ -- thing is non-strict. So exprIsHNF => bindings are non-strict
-- I think. The WARN below tests for this.
--
-- We use exprIsTrivial here because we want to reveal lone variables.
-- E.g. let { x = letrec { y = E } in y } in ...
-- Here we definitely want to float the y=E defn.
- -- exprIsValue definitely isn't right for that.
+ -- exprIsHNF definitely isn't right for that.
--
-- Again, the floated binding can't be strict; if it's recursive it'll
-- be non-strict; if it's non-recursive it'd be inlined.
import NewDemand -- All of it
import CoreSyn
import PprCore
-import CoreUtils ( exprIsValue, exprIsTrivial, exprArity )
+import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlinePragma,
res' = case res of
RetCPR | ignore_cpr_info -> TopRes
other -> res
- ignore_cpr_info = not (exprIsValue rhs || thunk_cpr_ok)
+ ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
\end{code}
The unpack strategy determines whether we'll *really* unpack the argument,
import CoreSyn
import CoreUnfold ( certainlyWillInline )
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprType, exprIsValue )
+import CoreUtils ( exprType, exprIsHNF )
import Id ( Id, idType, isOneShotLambda,
setIdNewStrictness, mkWorkerId,
setIdWorkerInfo, setInlinePragma,
StrictSig (mkTopDmdType wrap_dmds res_info)
is_fun = notNull wrap_dmds
- is_thunk = not is_fun && not (exprIsValue rhs)
+ is_thunk = not is_fun && not (exprIsHNF rhs)
---------------------
splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
projects / ghc-hetmet.git / commitdiff