projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add NondecreasingIndentation to the list of extensions in the ghc package
[ghc-hetmet.git]
/
compiler
/
coreSyn
/
CoreUtils.lhs
diff --git
a/compiler/coreSyn/CoreUtils.lhs
b/compiler/coreSyn/CoreUtils.lhs
index
8284702
..
2cf8885
100644
(file)
--- a/
compiler/coreSyn/CoreUtils.lhs
+++ b/
compiler/coreSyn/CoreUtils.lhs
@@
-25,7
+25,8
@@
module CoreUtils (
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
- exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
+ exprIsDupable, exprIsTrivial,
+ exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
@@
-55,10
+56,6
@@
import SrcLoc
import VarEnv
import VarSet
import Name
import VarEnv
import VarSet
import Name
-import Module
-#if mingw32_TARGET_OS
-import Packages
-#endif
import Literal
import DataCon
import PrimOp
import Literal
import DataCon
import PrimOp
@@
-517,8
+514,8
@@
exprIsCheap = exprIsCheap' isCheapApp
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
-
-exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool
+type CheapAppFun = Id -> Int -> Bool
+exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
exprIsCheap' _ (Lit _) = True
exprIsCheap' _ (Type _) = True
exprIsCheap' _ (Var _) = True
exprIsCheap' _ (Lit _) = True
exprIsCheap' _ (Type _) = True
exprIsCheap' _ (Var _) = True
@@
-552,7
+549,7
@@
exprIsCheap' good_app other_expr -- Applications and variables
go (Var _) [] = True -- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
go (Var f) args
go (Var _) [] = True -- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
go (Var f) args
- = case idDetails f of
+ = case idDetails f of
RecSelId {} -> go_sel args
ClassOpId {} -> go_sel args
PrimOpId op -> go_primop op args
RecSelId {} -> go_sel args
ClassOpId {} -> go_sel args
PrimOpId op -> go_primop op args
@@
-586,12
+583,12
@@
exprIsCheap' good_app other_expr -- Applications and variables
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
-isCheapApp :: Id -> Int -> Bool
+isCheapApp :: CheapAppFun
isCheapApp fn n_val_args
= isDataConWorkId fn
|| n_val_args < idArity fn
isCheapApp fn n_val_args
= isDataConWorkId fn
|| n_val_args < idArity fn
-isExpandableApp :: Id -> Int -> Bool
+isExpandableApp :: CheapAppFun
isExpandableApp fn n_val_args
= isConLikeId fn
|| n_val_args < idArity fn
isExpandableApp fn n_val_args
= isConLikeId fn
|| n_val_args < idArity fn
@@
-696,7
+693,7
@@
exprOkForSpeculation other_expr
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
- spec_ok (DFunId new_type) _ = not new_type
+ spec_ok (DFunId _ new_type) _ = not new_type
-- DFuns terminate, unless the dict is implemented with a newtype
-- in which case they may not
-- DFuns terminate, unless the dict is implemented with a newtype
-- in which case they may not
@@
-736,8
+733,8
@@
If exprOkForSpeculation doesn't look through case expressions, you get this:
\ (ww :: GHC.Prim.Int#) ->
case ww of ds {
__DEFAULT -> case (case <# ds 5 of _ {
\ (ww :: GHC.Prim.Int#) ->
case ww of ds {
__DEFAULT -> case (case <# ds 5 of _ {
- GHC.Bool.False -> lvl1;
- GHC.Bool.True -> lvl})
+ GHC.Types.False -> lvl1;
+ GHC.Types.True -> lvl})
of _ { __DEFAULT ->
T.$wfoo (GHC.Prim.-# ds_XkE 1) };
0 -> 0
of _ { __DEFAULT ->
T.$wfoo (GHC.Prim.-# ds_XkE 1) };
0 -> 0
@@
-1337,7
+1334,7
@@
and 'execute' it rather than allocating it statically.
-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
-rhsIsStatic :: PackageId -> CoreExpr -> Bool
+rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
@@
-1392,16
+1389,14
@@
rhsIsStatic :: PackageId -> CoreExpr -> Bool
--
-- c) don't look through unfolding of f in (f x).
--
-- c) don't look through unfolding of f in (f x).
-rhsIsStatic _this_pkg rhs = is_static False rhs
+rhsIsStatic _is_dynamic_name rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
- is_static False (Lam b e) = isRuntimeVar b || is_static False e
-
- is_static _ (Note (SCC _) _) = False
- is_static in_arg (Note _ e) = is_static in_arg e
- is_static in_arg (Cast e _) = is_static in_arg e
+ is_static False (Lam b e) = isRuntimeVar b || is_static False e
+ is_static in_arg (Note n e) = notSccNote n && is_static in_arg e
+ is_static in_arg (Cast e _) = is_static in_arg e
is_static _ (Lit lit)
= case lit of
is_static _ (Lit lit)
= case lit of
@@
-1420,7
+1415,7
@@
rhsIsStatic _this_pkg rhs = is_static False rhs
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
- | not (isDllName _this_pkg (idName f))
+ | not (_is_dynamic_name (idName f))
#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
@@
-1442,11
+1437,9
@@
rhsIsStatic _this_pkg rhs = is_static False rhs
-- x = D# (1.0## /## 2.0##)
-- can't float because /## can fail.
-- x = D# (1.0## /## 2.0##)
-- can't float because /## can fail.
- go (Note (SCC _) _) _ = False
- go (Note _ f) n_val_args = go f n_val_args
- go (Cast e _) n_val_args = go e n_val_args
-
- go _ _ = False
+ go (Note n f) n_val_args = notSccNote n && go f n_val_args
+ go (Cast e _) n_val_args = go e n_val_args
+ go _ _ = False
saturated_data_con f n_val_args
= case isDataConWorkId_maybe f of
saturated_data_con f n_val_args
= case isDataConWorkId_maybe f of