\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,
#include "HsVersions.h"
-import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
+import StaticFlags ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
-import CoreUnfold ( Unfolding, maybeUnfoldingTemplate )
-import Id ( Id, idType, idArity, idStrictness, idUnfolding, isDataConId_maybe )
+import CoreUnfold ( maybeUnfoldingTemplate )
+import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
+ idStrictness,
+ )
import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy,
- wwUnpackNew )
+import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
+ mkStrictnessInfo, isLazy
+ )
import SaLib
-import TyCon ( isProductTyCon, isRecursiveTyCon, isEnumerationTyCon, isNewTyCon )
-import BasicTypes ( Arity, NewOrData(..) )
-import Type ( splitAlgTyConApp_maybe,
+import TyCon ( isProductTyCon, isRecursiveTyCon )
+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}
evalStrictness WwStrict val = isBot val
evalStrictness WwEnum val = isBot val
-evalStrictness (WwUnpack NewType _ (demand:_)) val
- = evalStrictness demand val
-
-evalStrictness (WwUnpack DataType _ demand_info) val
+evalStrictness (WwUnpack _ demand_info) val
= 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
evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
-- with Absent demand
-evalAbsence (WwUnpack NewType _ (demand:_)) val
- = evalAbsence demand val
-
-evalAbsence (WwUnpack DataType _ demand_info) val
+evalAbsence (WwUnpack _ demand_info) val
= 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
absId anal var env
= case (lookupAbsValEnv env var,
- isDataConId_maybe var,
+ isDataConWorkId_maybe var,
idStrictness var,
maybeUnfoldingTemplate (idUnfolding var)) of
-- 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
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}
-- HOWEVER, if we make diverging functions appear lazy, they
-- don't get wrappers, and then we get dreadful reboxing.
-- See notes with WwLib.worthSplitting
- = StrictnessInfo (combineDemands id str_ds abs_ds) (isBot str_res)
+ = find_strictness id str_ds str_res abs_ds
-findStrictness id str_val abs_val = NoStrictnessInfo
+findStrictness id str_val abs_val
+ | isBot str_val = mkStrictnessInfo ([], True)
+ | otherwise = NoStrictnessInfo
-- The list of absence demands passed to combineDemands
-- can be shorter than the list of absence demands
-- Here the strictness value takes three args, but the absence value
-- takes only one, for reasons I don't quite understand (see cheapFixpoint)
-combineDemands id orig_str_ds orig_abs_ds
- = go orig_str_ds orig_abs_ds
+find_strictness id orig_str_ds orig_str_res orig_abs_ds
+ = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
where
+ res_bot = isBot orig_str_res
+
go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
- mk_dmd str_dmd (WwLazy True) = WARN( case str_dmd of { WwLazy _ -> False; other -> True },
- ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
- WwLazy True -- Best of all
- mk_dmd (WwUnpack nd u str_ds)
- (WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds)
+ mk_dmd str_dmd (WwLazy True)
+ = WARN( not (res_bot || isLazy str_dmd),
+ ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
+ -- If the arg isn't used we jolly well don't expect the function
+ -- to be strict in it. Unless the function diverges.
+ WwLazy True -- Best of all
+
+ mk_dmd (WwUnpack u str_ds)
+ (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
mk_dmd str_dmd abs_dmd = str_dmd
\end{code}
-- we don't exploit it yet, so don't bother
Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case
- | isNewTyCon tycon -- A newtype!
- -> ASSERT( null (tail cmpnt_tys) )
- let
- demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
- in
- wwUnpackNew demand
+ | isRecursiveTyCon tycon -- Recursive data type; don't unpack
+ -> wwStrict -- (this applies to newtypes too:
+ -- e.g. data Void = MkVoid Void)
| null compt_strict_infos -- A nullary data type
- || isRecursiveTyCon tycon -- Recursive data type; don't unpack
-> wwStrict
| otherwise -- Some other data type
- -> wwUnpackData compt_strict_infos
+ -> wwUnpack compt_strict_infos
where
prod_len = length cmpnt_tys
where
is_numeric_type ty
- = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above
- Nothing -> False
- Just (tycon, _, _)
- | tyConUnique tycon `is_elem` numericTyKeys
- -> True
- _{-something else-} -> False
+ = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
+ Nothing -> False
+ Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
where
is_elem = isIn "is_numeric_type"
AbsAnal -> AbsBot
\end{code}
-\begin{verbatim}
-mkLookupFun :: (key -> key -> Bool) -- Equality predicate
- -> (key -> key -> Bool) -- Less-than predicate
- -> [(key,val)] -- The assoc list
- -> key -- The key
- -> Maybe val -- The corresponding value
-
-mkLookupFun eq lt alist s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> Nothing
- (a:_) -> Just a
-\end{verbatim}
-
\begin{code}
fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
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}
projects / ghc-hetmet.git / blobdiff