import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
-import Pretty ( ppStr )
+import Pretty ( ppPStr )
import PrimOp ( PrimOp(..) )
import SaLib
import TyCon ( maybeTyConSingleCon, isEnumerationTyCon,
else
AbsBot
where
- is_fun (AbsFun _ _ _) = True
- is_fun (AbsApproxFun _) = True -- Not used, but the glb works ok
- is_fun other = False
+ is_fun (AbsFun _ _ _) = True
+ is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
+ is_fun other = False
-- The non-functional cases are quite straightforward
\begin{code}
isBot :: AbsVal -> Bool
-isBot AbsBot = True
-isBot (AbsFun args body env) = isBot (absEval StrAnal body env)
+isBot AbsBot = True
+isBot (AbsFun arg body env) = isBot (absEval StrAnal body env)
-- Don't bother to extend the envt because
-- unbound variables default to AbsTop anyway
-isBot other = False
+isBot other = False
\end{code}
Used only in absence analysis:
anyBot AbsBot = True -- poisoned!
anyBot AbsTop = False
anyBot (AbsProd vals) = any anyBot vals
-anyBot (AbsFun args body env) = anyBot (absEval AbsAnal body env)
-anyBot (AbsApproxFun demands) = False
+anyBot (AbsFun arg body env) = anyBot (absEval AbsAnal body env)
+anyBot (AbsApproxFun _ _) = False
-- AbsApproxFun can only arise in absence analysis from the Demand
-- info of an imported value; whatever it is we're looking for is
\begin{code}
widen :: AnalysisKind -> AbsVal -> AbsVal
-widen StrAnal (AbsFun args body env)
- | isBot (absEval StrAnal body env) = AbsBot
- | otherwise
- = ASSERT (not (null args))
- AbsApproxFun (map (findDemandStrOnly env body) args)
+widen StrAnal (AbsFun arg body env)
+ = AbsApproxFun (findDemandStrOnly env body arg)
+ (widen StrAnal abs_body)
+ where
+ abs_body = absEval StrAnal body env
+
+{- OLD comment...
+ This stuff is now instead handled neatly by the fact that AbsApproxFun
+ contains an AbsVal inside it. SLPJ Jan 97
+ | isBot abs_body = AbsBot
-- It's worth checking for a function which is unconditionally
-- bottom. Consider
--
-- alternative here would be to bind g to its exact abstract
-- value, but that entails lots of potential re-computation, at
-- every application of g.)
+-}
widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
widen StrAnal other_val = other_val
-widen AbsAnal (AbsFun args body env)
- | anyBot (absEval AbsAnal body env) = AbsBot
+widen AbsAnal (AbsFun arg body env)
+ | anyBot abs_body = AbsBot
-- In the absence-analysis case it's *essential* to check
-- that the function has no poison in its body. If it does,
-- anywhere, then the whole function is poisonous.
| otherwise
- = ASSERT (not (null args))
- AbsApproxFun (map (findDemandAbsOnly env body) args)
+ = AbsApproxFun (findDemandAbsOnly env body arg)
+ (widen AbsAnal abs_body)
+ where
+ abs_body = absEval AbsAnal body env
widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
sameVal (AbsProd _) AbsTop = False
sameVal (AbsProd _) AbsBot = False
-sameVal (AbsApproxFun str1) (AbsApproxFun str2) = str1 == str2
-sameVal (AbsApproxFun _) AbsTop = False
-sameVal (AbsApproxFun _) AbsBot = False
+sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v1
+sameVal (AbsApproxFun _ _) AbsTop = False
+sameVal (AbsApproxFun _ _) AbsBot = False
sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
\end{code}
evalStrictness WwStrict val = isBot val
evalStrictness WwEnum val = isBot val
-evalStrictness (WwUnpack 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 demand_info) val
+evalAbsence (WwUnpack _ demand_info) val
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, noStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
+ (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
-- Try the strictness info
absValFromStrictness anal strictness_info
in
- -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) $
+ -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppPStr SLIT("=:"), pp_anal anal, ppStr SLIT(":="),ppr PprDebug result]) $
result
where
- pp_anal StrAnal = ppStr "STR"
- pp_anal AbsAnal = ppStr "ABS"
+ pp_anal StrAnal = ppPStr SLIT("STR")
+ pp_anal AbsAnal = ppPStr SLIT("ABS")
absEvalAtom anal (VarArg v) env = absId anal v env
absEvalAtom anal (LitArg _) env = AbsTop
\begin{code}
absEval anal (Lam (ValBinder binder) body) env
- = AbsFun [binder] body env
+ = AbsFun binder body env
absEval anal (Lam other_binder expr) env
= absEval anal expr env
absEval anal (App f a) env | isValArg a
an augmented environment.
\begin{code}
-absApply anal (AbsFun [binder] body env) arg
+absApply anal (AbsFun binder body env) arg
= absEval anal body (addOneToAbsValEnv env binder arg)
-
-absApply anal (AbsFun (binder:bs) body env) arg
- = AbsFun bs body (addOneToAbsValEnv env binder arg)
\end{code}
\begin{code}
-absApply StrAnal (AbsApproxFun (arg1_demand:ds)) arg
- = if evalStrictness arg1_demand arg
+absApply StrAnal (AbsApproxFun demand val) arg
+ = if evalStrictness demand arg
then AbsBot
- else case ds of
- [] -> AbsTop
- other -> AbsApproxFun ds
+ else val
-absApply AbsAnal (AbsApproxFun (arg1_demand:ds)) arg
- = if evalAbsence arg1_demand arg
+absApply AbsAnal (AbsApproxFun demand val) arg
+ = if evalAbsence demand arg
then AbsBot
- else case ds of
- [] -> AbsTop
- other -> AbsApproxFun ds
+ else val
#ifdef DEBUG
-absApply anal (AbsApproxFun []) arg = panic ("absApply: Duff function: AbsApproxFun." ++ show anal)
-absApply anal (AbsFun [] _ _) arg = panic ("absApply: Duff function: AbsFun." ++ show anal)
absApply anal (AbsProd _) arg = panic ("absApply: Duff function: AbsProd." ++ show anal)
#endif
\end{code}
projects / ghc-hetmet.git / blobdiff