import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
-import CoreUnfold ( Unfolding, maybeUnfoldingTemplate )
-import PrimOp ( primOpStrictness )
-import Id ( Id, idType, getIdStrictness, getIdUnfolding )
-import Const ( Con(..) )
-import DataCon ( dataConTyCon, dataConArgTys )
+import CoreUnfold ( maybeUnfoldingTemplate )
+import Id ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
+import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData,
- wwUnpackNew )
+import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
+ mkStrictnessInfo, isLazy
+ )
import SaLib
-import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon )
-import BasicTypes ( 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 Outputable
-
-returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
\end{code}
%************************************************************************
\begin{code}
lub, glb :: AbsVal -> AbsVal -> AbsVal
-lub val1 val2 | isBot val1 = val2 -- The isBot test includes the case where
-lub val1 val2 | isBot val2 = val1 -- one of the val's is a function which
- -- always returns bottom, such as \y.x,
- -- when x is bound to bottom.
+lub AbsBot val2 = val2
+lub val1 AbsBot = val1
lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
else
AbsBot
where
- is_fun (AbsFun _ _ _) = True
+ is_fun (AbsFun _ _) = True
is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
is_fun other = False
isBot AbsBot = True
isBot other = False -- Functions aren't bottom any more
-
\end{code}
Used only in absence analysis:
+
\begin{code}
anyBot :: AbsVal -> Bool
-anyBot AbsBot = True -- poisoned!
-anyBot AbsTop = False
-anyBot (AbsProd vals) = any anyBot vals
-anyBot (AbsFun bndr body env) = anyBot (absEval AbsAnal body (addOneToAbsValEnv env bndr AbsTop))
-anyBot (AbsApproxFun _ val) = anyBot val
+anyBot AbsBot = True -- poisoned!
+anyBot AbsTop = False
+anyBot (AbsProd vals) = any anyBot vals
+anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop)
+anyBot (AbsApproxFun _ val) = anyBot val
\end{code}
@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
widen :: AnalysisKind -> AbsVal -> AbsVal
-- Widening is complicated by the fact that funtions are lifted
-widen StrAnal the_fn@(AbsFun bndr body env)
+widen StrAnal the_fn@(AbsFun bndr_ty _)
= case widened_body of
AbsApproxFun ds val -> AbsApproxFun (d : ds) val
where
d = findRecDemand str_fn abs_fn bndr_ty
- str_fn val = foldl (absApply StrAnal) the_fn
- (val : [AbsTop | d <- ds])
+ str_fn val = isBot (foldl (absApply StrAnal) the_fn
+ (val : [AbsTop | d <- ds]))
other -> AbsApproxFun [d] widened_body
where
d = findRecDemand str_fn abs_fn bndr_ty
- str_fn val = absApply StrAnal the_fn val
+ str_fn val = isBot (absApply StrAnal the_fn val)
where
- bndr_ty = idType bndr
widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
- abs_fn val = AbsBot -- Always says poison; so it looks as if
+ abs_fn val = False -- Always says poison; so it looks as if
-- nothing is absent; safe
{- OLD comment...
widen StrAnal other_val = other_val
-widen AbsAnal the_fn@(AbsFun bndr body env)
+widen AbsAnal the_fn@(AbsFun bndr_ty _)
| anyBot widened_body = AbsBot
-- In the absence-analysis case it's *essential* to check
-- that the function has no poison in its body. If it does,
AbsApproxFun ds val -> AbsApproxFun (d : ds) val
where
d = findRecDemand str_fn abs_fn bndr_ty
- abs_fn val = foldl (absApply AbsAnal) the_fn
- (val : [AbsTop | d <- ds])
+ abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn
+ (val : [AbsTop | d <- ds])))
other -> AbsApproxFun [d] widened_body
where
d = findRecDemand str_fn abs_fn bndr_ty
- abs_fn val = absApply AbsAnal the_fn val
+ abs_fn val = not (anyBot (absApply AbsAnal the_fn val))
where
- bndr_ty = idType bndr
widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
- str_fn val = AbsBot -- Always says non-termination;
+ str_fn val = True -- Always says non-termination;
-- that'll make findRecDemand peer into the
-- structure of the value.
sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun!
#ifdef DEBUG
-sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1"
-sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2"
+sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
+sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
#endif
sameVal AbsBot AbsBot = True
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
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
-- error's arg
absId anal var env
- = case (lookupAbsValEnv env var, getIdStrictness var, maybeUnfoldingTemplate (getIdUnfolding var)) of
+ = case (lookupAbsValEnv env var,
+ isDataConId_maybe var,
+ idStrictness var,
+ maybeUnfoldingTemplate (idUnfolding var)) of
- (Just abs_val, _, _) ->
+ (Just abs_val, _, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, Just unfolding) ->
+ (_, Just data_con, _, _) | isProductTyCon tycon &&
+ not (isRecursiveTyCon tycon)
+ -> -- A product. We get infinite loops if we don't
+ -- check for recursive products!
+ -- The strictness info on the constructor
+ -- isn't expressive enough to contain its abstract value
+ productAbsVal (dataConRepArgTys data_con) []
+ where
+ tycon = dataConTyCon data_con
+
+ (_, _, NoStrictnessInfo, Just unfolding) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
-- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
- (Nothing, strictness_info, _) ->
+ (_, _, strictness_info, _) ->
-- Includes NoUnfolding
-- Try the strictness info
absValFromStrictness anal strictness_info
+
+productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args)
+productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args))
\end{code}
\begin{code}
to make sure that any poison (?????)
\begin{code}
-absEval anal (Con (Literal _) args) env
- = -- Literals terminate (strictness) and are not poison (absence)
- AbsTop
-
-absEval anal (Con (PrimOp op) args) env
- = -- Not all PrimOps evaluate all their arguments
- if or (zipWith (check_arg anal)
- [absEval anal arg env | arg <- args, isValArg arg]
- arg_demands)
- then AbsBot
- else case anal of
- StrAnal | result_bot -> AbsBot
- other -> AbsTop
- where
- (arg_demands, result_bot) = primOpStrictness op
- check_arg StrAnal arg dmd = evalStrictness dmd arg
- check_arg AbsAnal arg dmd = evalAbsence dmd arg
-
-absEval anal (Con (DataCon con) args) env
- | isProductTyCon (dataConTyCon con)
- = -- Products; filter out type arguments
- AbsProd [absEval anal a env | a <- args, isValArg a]
-
- | otherwise -- Not single-constructor
- = case anal of
- StrAnal -> -- Strictness case: it's easy: it certainly terminates
- AbsTop
- AbsAnal -> -- In the absence case we need to be more
- -- careful: look to see if there's any
- -- poison in the components
- if any anyBot [absEval AbsAnal arg env | arg <- args]
- then AbsBot
- else AbsTop
+absEval anal (Lit _) env = AbsTop
+ -- Literals terminate (strictness) and are not poison (absence)
\end{code}
\begin{code}
absEval anal (Lam bndr body) env
| isTyVar bndr = absEval anal body env -- Type lambda
- | otherwise = AbsFun bndr body env -- Value lambda
+ | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda
+ where
+ abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg)
absEval anal (App expr (Type ty)) env
= absEval anal expr env -- Type appplication
an augmented environment.
\begin{code}
-absApply anal (AbsFun binder body env) arg
- = absEval anal body (addOneToAbsValEnv env binder arg)
+absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
\end{code}
\begin{code}
other -> AbsApproxFun ds val
#ifdef DEBUG
-absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
+absApply anal f@(AbsProd _) arg
+ = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
#endif
\end{code}
%* *
%************************************************************************
-@findStrictness@ applies the function \tr{\ ids -> expr} to
-\tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once
-with @AbsBot@ in each argument position), and evaluates the resulting
-abstract value; it returns a vector of @Demand@s saying whether the
-result of doing this is guaranteed to be bottom. This tells the
-strictness of the function in each of the arguments.
-
-If an argument is of unboxed type, then we declare that function to be
-strict in that argument.
-
-We don't really have to make up all those lists of mostly-@AbsTops@;
-unbound variables in an @AbsValEnv@ are implicitly mapped to that.
-
-See notes on @addStrictnessInfoToId@.
-
\begin{code}
-findStrictness :: [Type] -- Types of args in which strictness is wanted
+findStrictness :: Id
-> AbsVal -- Abstract strictness value of function
-> AbsVal -- Abstract absence value of function
- -> ([Demand], Bool) -- Resulting strictness annotation
+ -> StrictnessInfo -- Resulting strictness annotation
+
+findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _)
+ -- You might think there's really no point in describing detailed
+ -- strictness for a divergent function;
+ -- If it's fully applied we get bottom regardless of the
+ -- argument. If it's not fully applied we don't get bottom.
+ -- Finally, we don't want to regard the args of a divergent function
+ -- as 'interesting' for inlining purposes (see Simplify.prepareArgs)
+ --
+ -- HOWEVER, if we make diverging functions appear lazy, they
+ -- don't get wrappers, and then we get dreadful reboxing.
+ -- See notes with WwLib.worthSplitting
+ = find_strictness id str_ds str_res abs_ds
+
+findStrictness id str_val abs_val
+ | isBot str_val = mkStrictnessInfo ([], True)
+ | otherwise = NoStrictnessInfo
-findStrictness tys str_val abs_val
- = (map find_str tys_w_index, isBot (foldl (absApply StrAnal) str_val all_tops))
+-- The list of absence demands passed to combineDemands
+-- can be shorter than the list of absence demands
+--
+-- lookup = \ dEq -> letrec {
+-- lookup = \ key ds -> ...lookup...
+-- }
+-- in lookup
+-- Here the strictness value takes three args, but the absence value
+-- takes only one, for reasons I don't quite understand (see cheapFixpoint)
+
+find_strictness id orig_str_ds orig_str_res orig_abs_ds
+ = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
where
- tys_w_index = tys `zip` [(1::Int) ..]
+ res_bot = isBot orig_str_res
- find_str (ty,n) = findRecDemand str_fn abs_fn ty
- where
- str_fn val = foldl (absApply StrAnal) str_val
- (map (mk_arg val n) tys_w_index)
+ go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
- abs_fn val = foldl (absApply AbsAnal) abs_val
- (map (mk_arg val n) tys_w_index)
+ 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_arg val n (_,m) | m==n = val
- | otherwise = AbsTop
+ mk_dmd (WwUnpack u str_ds)
+ (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
- all_tops = [AbsTop | _ <- tys]
+ mk_dmd str_dmd abs_dmd = str_dmd
\end{code}
\begin{code}
-findDemand str_env abs_env expr binder
+findDemand dmd str_env abs_env expr binder
= findRecDemand str_fn abs_fn (idType binder)
where
- str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
- abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
+ str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val))
+ abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)))
-findDemandAlts str_env abs_env alts binder
+findDemandAlts dmd str_env abs_env alts binder
= findRecDemand str_fn abs_fn (idType binder)
where
- str_fn val = absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val)
- abs_fn val = absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)
+ str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val))
+ abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)))
\end{code}
@findRecDemand@ is where we finally convert strictness/absence info
Ho hum.
\begin{code}
-findRecDemand :: (AbsVal -> AbsVal) -- The strictness function
- -> (AbsVal -> AbsVal) -- The absence function
+findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot
+ -> (AbsVal -> Bool) -- True => function applied to this value yields no poison
-> Type -- The type of the argument
-> Demand
= if isUnLiftedType ty then -- It's a primitive type!
wwPrim
- else if not (anyBot (abs_fn AbsBot)) then -- It's absent
+ else if abs_fn AbsBot then -- It's absent
-- We prefer absence over strictness: see NOTE above.
WwLazy True
else if not (opt_AllStrict ||
- (opt_NumbersStrict && is_numeric_type ty) ||
- (isBot (str_fn AbsBot))) then
+ (opt_NumbersStrict && is_numeric_type ty) ||
+ str_fn AbsBot) then
WwLazy False -- It's not strict and we're not pretending
else -- It's strict (or we're pretending it is)!
- case (splitAlgTyConApp_maybe ty) of
+ case splitProductType_maybe ty of
+
+ Nothing -> wwStrict -- Could have a test for wwEnum, but
+ -- we don't exploit it yet, so don't bother
+
+ Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case
+ | isRecursiveTyCon tycon -- Recursive data type; don't unpack
+ -> wwStrict -- (this applies to newtypes too:
+ -- e.g. data Void = MkVoid Void)
- Nothing -> wwStrict
+ | null compt_strict_infos -- A nullary data type
+ -> wwStrict
- Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon ->
- -- Non-recursive, single constructor case
- let
- cmpnt_tys = dataConArgTys data_con tycon_arg_tys
+ | otherwise -- Some other data type
+ -> wwUnpack compt_strict_infos
+
+ where
prod_len = length cmpnt_tys
- in
-
- if isNewTyCon tycon then -- A newtype!
- ASSERT( null (tail cmpnt_tys) )
- let
- demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
- in
- wwUnpackNew demand
- else -- A data type!
- let
compt_strict_infos
= [ findRecDemand
(\ cmpnt_val ->
)
cmpnt_ty
| (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
- in
- if null compt_strict_infos then
- if isEnumerationTyCon tycon then wwEnum else wwStrict
- else
- wwUnpackData compt_strict_infos
-
- Just (tycon,_,_) ->
- -- Multi-constr data types, *or* an abstract data
- -- types, *or* things we don't have a way of conveying
- -- the info over module boundaries (class ops,
- -- superdict sels, dfns).
- if isEnumerationTyCon tycon then
- wwEnum
- else
- wwStrict
+
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]
where
initial_val id
= case anal of -- The (unsafe) starting point
- StrAnal -> if (returnsRealWorld (idType id))
- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
- else AbsBot
AbsAnal -> AbsTop
+ StrAnal -> AbsBot
+ -- At one stage for StrAnal we said:
+ -- if (returnsRealWorld (idType id))
+ -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
+ -- but no one has the foggiest idea what this hack did,
+ -- and returnsRealWorld was a stub that always returned False
+ -- So this comment is all that is left of the hack!
initial_vals = [ initial_val id | id <- ids ]
projects / ghc-hetmet.git / blobdiff