From: simonpj Date: Wed, 10 Aug 2005 11:09:07 +0000 (+0000) Subject: [project @ 2005-08-10 11:09:05 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~251 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=70cfef77ff00fbd4a57f733045e62ce0a7ba1307 [project @ 2005-08-10 11:09:05 by simonpj] Rename exprIsValue to exprIsHNF, which is more accurate --- diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index d2c2c53..e5165f0 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -10,7 +10,7 @@ module CorePrep ( #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 @@ -544,7 +544,7 @@ maybeSaturate fn expr n_args floats ty -- 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 -> @@ -573,7 +573,7 @@ floatRhs :: TopLevelFlag -> RecFlag 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) @@ -606,7 +606,7 @@ mkLocalNonRec bndr dem floats rhs = 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) @@ -614,7 +614,7 @@ mkLocalNonRec bndr dem floats rhs | 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 diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 2f6efd4..201d866 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -55,7 +55,6 @@ import OccName ( OccName ) import Literal ( Literal, mkMachInt ) import DataCon ( DataCon, dataConWorkId, dataConTag ) import BasicTypes ( Activation ) -import VarSet import FastString import Outputable \end{code} @@ -254,7 +253,7 @@ data Unfolding | 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 diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index a0050d5..14a0f4d 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -38,7 +38,7 @@ import DynFlags ( DynFlags, DynFlag(..), dopt ) 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 ) @@ -72,7 +72,7 @@ mkUnfolding top_lvl expr = CoreUnfolding (occurAnalyseExpr expr) top_lvl - (exprIsValue expr) + (exprIsHNF expr) -- Already evaluated (exprIsCheap expr) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index d3cc3d7..53761d5 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -16,7 +16,7 @@ module CoreUtils ( -- Properties of expressions exprType, coreAltType, exprIsDupable, exprIsTrivial, exprIsCheap, - exprIsValue,exprOkForSpeculation, exprIsBig, + exprIsHNF,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsBottom, rhsIsStatic, @@ -557,7 +557,7 @@ idAppIsBottom :: Id -> Int -> Bool 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 @@ -581,8 +581,8 @@ this form is illegal (see the invariants in CoreSyn). Args of unboxed 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 @@ -591,14 +591,14 @@ exprIsValue (Var v) -- NB: There are no value args at this point -- 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 @@ -1212,7 +1212,7 @@ rhsIsStatic :: HomeModules -> CoreExpr -> Bool -- 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 diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 8ca265f..dad6ccb 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -14,7 +14,7 @@ module CprAnalyse ( cprAnalyse ) where 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(..) ) @@ -273,7 +273,7 @@ addIdCprInfo bndr rhs absval 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 diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index ae6ce75..0e8edb5 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -18,7 +18,7 @@ module FloatIn ( floatInwards ) where 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 ) @@ -355,7 +355,7 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- 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} diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index a53d0c6..988bd53 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -11,7 +11,7 @@ module FloatOut ( floatOutwards ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( mkSCC, exprIsValue, exprIsTrivial ) +import CoreUtils ( mkSCC, exprIsHNF, exprIsTrivial ) import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) import ErrUtils ( dumpIfSet_dyn ) @@ -243,7 +243,7 @@ floatNonRecRhs lvl arg -- Used for nested non-rec rhss, and fn args -- 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) -> diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 499cfbd..5e12c5e 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -32,7 +32,7 @@ import CoreSyn 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, @@ -607,7 +607,7 @@ preInlineUnconditionally env top_lvl bndr rhs -- 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 @@ -796,9 +796,9 @@ tryEtaReduce bndrs body 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. -- @@ -1471,7 +1471,7 @@ mkCase1 scrut case_bndr ty [(con,bndrs,rhs)] -- 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! diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index a537e59..144b26a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -43,7 +43,7 @@ import PprCore ( pprParendExpr, pprCoreExpr ) 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 ) @@ -524,24 +524,24 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se 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. diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 1066b77..f0dcc00 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -18,7 +18,7 @@ import StaticFlags ( opt_MaxWorkerArgs ) 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, @@ -593,7 +593,7 @@ mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res) 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, diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 28a465b..64eba89 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -11,7 +11,7 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where 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, @@ -244,7 +244,7 @@ tryWW is_rec fn_id rhs 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