projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2003-07-24 10:47:05 by simonmar]
[ghc-hetmet.git]
/
ghc
/
compiler
/
stranal
/
SaAbsInt.lhs
diff --git
a/ghc/compiler/stranal/SaAbsInt.lhs
b/ghc/compiler/stranal/SaAbsInt.lhs
index
faa2346
..
3cd9ba4
100644
(file)
--- a/
ghc/compiler/stranal/SaAbsInt.lhs
+++ b/
ghc/compiler/stranal/SaAbsInt.lhs
@@
-4,6
+4,11
@@
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
+#ifndef OLD_STRICTNESS
+-- If OLD_STRICTNESS is off, omit all exports
+module SaAbsInt () where
+
+#else
module SaAbsInt (
findStrictness,
findDemand, findDemandAlts,
module SaAbsInt (
findStrictness,
findDemand, findDemandAlts,
@@
-18,7
+23,9
@@
module SaAbsInt (
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
import CoreUnfold ( maybeUnfoldingTemplate )
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
import CoreUnfold ( maybeUnfoldingTemplate )
-import Id ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
+import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
+ idStrictness,
+ )
import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
import IdInfo ( StrictnessInfo(..) )
import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
import IdInfo ( StrictnessInfo(..) )
import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
@@
-26,12
+33,11
@@
import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
)
import SaLib
import TyCon ( isProductTyCon, isRecursiveTyCon )
)
import SaLib
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import BasicTypes ( NewOrData(..) )
import Type ( splitTyConApp_maybe,
isUnLiftedType, Type )
import TyCon ( tyConUnique )
import PrelInfo ( numericTyKeys )
import Type ( splitTyConApp_maybe,
isUnLiftedType, Type )
import TyCon ( tyConUnique )
import PrelInfo ( numericTyKeys )
-import Util ( isIn, nOfThem, zipWithEqual )
+import Util ( isIn, nOfThem, zipWithEqual, equalLength )
import Outputable
\end{code}
import Outputable
\end{code}
@@
-289,8
+295,12
@@
evalStrictness (WwUnpack _ demand_info) val
= case val of
AbsTop -> False
AbsBot -> True
= case val of
AbsTop -> False
AbsBot -> True
- AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
- _ -> pprTrace "evalStrictness?" empty False
+ AbsProd vals
+ | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
+ False
+ | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
+
+ _ -> pprTrace "evalStrictness?" empty False
evalStrictness WwPrim val
= case val of
evalStrictness WwPrim val
= case val of
@@
-314,8
+324,13
@@
evalAbsence (WwUnpack _ demand_info) val
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
- AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
- _ -> panic "evalAbsence: other"
+ AbsProd vals
+ | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
+ True
+ | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
+ _ -> pprTrace "TELL SIMON: evalAbsence"
+ (ppr demand_info $$ ppr val)
+ True
evalAbsence other val = anyBot val
-- The demand is conservative; even "Lazy" *might* evaluate the
evalAbsence other val = anyBot val
-- The demand is conservative; even "Lazy" *might* evaluate the
@@
-338,7
+353,7
@@
evalAbsence other val = anyBot val
absId anal var env
= case (lookupAbsValEnv env var,
absId anal var env
= case (lookupAbsValEnv env var,
- isDataConId_maybe var,
+ isDataConWorkId_maybe var,
idStrictness var,
maybeUnfoldingTemplate (idUnfolding var)) of
idStrictness var,
maybeUnfoldingTemplate (idUnfolding var)) of
@@
-451,7
+466,7
@@
absEval anal expr@(Case scrut case_bndr alts) env
-- type; so the constructor in this alternative must be the right one
-- so we can go ahead and bind the constructor args to the components
-- of the product value.
-- type; so the constructor in this alternative must be the right one
-- so we can go ahead and bind the constructor args to the components
-- of the product value.
- ASSERT(length arg_vals == length val_bndrs)
+ ASSERT(equalLength arg_vals val_bndrs)
absEval anal rhs rhs_env
where
val_bndrs = filter isId bndrs
absEval anal rhs rhs_env
where
val_bndrs = filter isId bndrs
@@
-501,6
+516,11
@@
absEval anal (Let (Rec pairs) body) env
in
absEval anal body new_env
in
absEval anal body new_env
+absEval anal (Note (Coerce _ _) expr) env = AbsTop
+ -- Don't look inside coerces, becuase they
+ -- are usually recursive newtypes
+ -- (Could improve, for the error case, but we're about
+ -- to kill this analyser anyway.)
absEval anal (Note note expr) env = absEval anal expr env
\end{code}
absEval anal (Note note expr) env = absEval anal expr env
\end{code}
@@
-899,3
+919,7
@@
used. But who cares about missing that?
NB: despite only having a two-point domain, we may still have many
iterations, because there are several variables involved at once.
NB: despite only having a two-point domain, we may still have many
iterations, because there are several variables involved at once.
+
+\begin{code}
+#endif /* OLD_STRICTNESS */
+\end{code}