isBot
) where
-IMPORT_Trace -- ToDo: rm
-import Pretty
---import FiniteMap
-import Outputable
-
-import PrelInfo ( PrimOp(..),
- intTyCon, integerTyCon, doubleTyCon,
- floatTyCon, wordTyCon, addrTyCon,
- PrimRep
- )
-import Type ( isPrimType, maybeDataTyCon,
- maybeSingleConstructorTyCon,
- returnsRealWorld,
- isEnumerationTyCon, TyVarTemplate, TyCon
- )
+IMP_Ubiq(){-uitous-}
+
+import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
+import CoreSyn
+import CoreUnfold ( Unfolding(..), UfExpr, RdrName, SimpleUnfolding(..), FormSummary )
import CoreUtils ( unTagBinders )
-import Id ( getIdStrictness, idType, getIdUnfolding,
- getDataConSig, getInstantiatedDataConSig,
- DataCon(..), isBottomingId
+import Id ( idType, getIdStrictness, getIdUnfolding,
+ dataConTyCon, dataConArgTys, SYN_IE(Id)
)
-import IdInfo -- various bits
-import Maybes ( maybeToBool, Maybe(..) )
+import IdInfo ( StrictnessInfo(..) )
+import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwUnpackNew )
+import MagicUFs ( MagicUnfoldingFun )
+import Maybes ( maybeToBool )
+import Outputable
+import Pretty --TEMP:( Doc, ptext )
+import PrimOp ( PrimOp(..) )
import SaLib
-import Util
+import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, isNewTyCon,
+ TyCon{-instance Eq-}
+ )
+import BasicTypes ( NewOrData(..) )
+import Type ( maybeAppDataTyConExpandingDicts,
+ isPrimType, SYN_IE(Type) )
+import TysWiredIn ( intTyCon, integerTyCon, doubleTyCon,
+ floatTyCon, wordTyCon, addrTyCon
+ )
+import Util ( isIn, isn'tIn, nOfThem, zipWithEqual,
+ pprTrace, panic, pprPanic, assertPanic
+ )
+
+returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
\end{code}
%************************************************************************
-- always returns bottom, such as \y.x,
-- when x is bound to bottom.
-lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual lub xs ys)
+lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
lub _ _ = AbsTop -- Crude, but conservative
-- The crudity only shows up if there
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
-glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual glb xs ys)
+glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
glb AbsTop v2 = v2
glb v1 AbsTop = v1
\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 AbsTop AbsTop = True
sameVal AbsTop other = False -- Right?
-sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual sameVal vals1 vals2)
+sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
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 NewType _ (demand:_)) val
+ = evalStrictness demand val
+
+evalStrictness (WwUnpack DataType _ demand_info) val
= case val of
AbsTop -> False
AbsBot -> True
- AbsProd vals -> or (zipWithEqual evalStrictness demand_info vals)
+ AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
_ -> trace "evalStrictness?" False
evalStrictness WwPrim val
evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
-- with Absent demand
-evalAbsence (WwUnpack demand_info) val
+evalAbsence (WwUnpack NewType _ (demand:_)) val
+ = evalAbsence demand val
+
+evalAbsence (WwUnpack DataType _ demand_info) val
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
- AbsProd vals -> or (zipWithEqual evalAbsence demand_info vals)
+ AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
_ -> panic "evalAbsence: other"
evalAbsence other val = anyBot val
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, LitForm _) ->
- AbsTop -- Literals all terminate, and have no poison
-
- (Nothing, NoStrictnessInfo, ConForm _ _ _) ->
- AbsTop -- An imported constructor won't have
- -- bottom components, nor poison!
-
- (Nothing, NoStrictnessInfo, GenForm _ _ 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
(Nothing, strictness_info, _) ->
- -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
+ -- Includes MagicUnfolding, NoUnfolding
-- Try the strictness info
absValFromStrictness anal strictness_info
-
-
- -- Done via strictness now
- -- GenForm _ BottomForm _ _ -> AbsBot
in
- -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
+ -- pprTrace "absId:" (hcat [ppr PprDebug var, ptext SLIT("=:"), pp_anal anal, text SLIT(":="),ppr PprDebug result]) $
result
- -- )
where
- pp_anal StrAnal = ppStr "STR"
- pp_anal AbsAnal = ppStr "ABS"
+ pp_anal StrAnal = ptext SLIT("STR")
+ pp_anal AbsAnal = ptext SLIT("ABS")
absEvalAtom anal (VarArg v) env = absId anal v env
absEvalAtom anal (LitArg _) env = AbsTop
to make sure that any poison (?????)
\begin{code}
-absEval StrAnal (Prim SeqOp [t] [e]) env
- = if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
+absEval StrAnal (Prim SeqOp [TyArg _, e]) env
+ = ASSERT(isValArg e)
+ if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
-- This is a special case to ensure that seq# is strict in its argument.
-- The comments below (for most normal PrimOps) do not apply.
-absEval StrAnal (Prim op ts es) env = AbsTop
+absEval StrAnal (Prim op es) env = AbsTop
-- The arguments are all of unboxed type, so they will already
-- have been eval'd. If the boxed version was bottom, we'll
-- already have returned bottom.
-- uses boxed args and we don't know whether or not it's
-- strict, so we assume laziness. (JSM)
-absEval AbsAnal (Prim op ts as) env
- = if any anyBot [absEvalAtom AbsAnal a env | a <- as]
+absEval AbsAnal (Prim op as) env
+ = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
then AbsBot
else AbsTop
-- For absence analysis, we want to see if the poison shows up...
-absEval anal (Con con ts as) env
+absEval anal (Con con as) env
| has_single_con
- = AbsProd [absEvalAtom anal a env | a <- as]
+ = --pprTrace "absEval.Con" (cat[ text "con: ", (ppr PprDebug con), text "args: ", interppSP PprDebug as]) $
+ AbsProd [absEvalAtom anal a env | a <- as, isValArg a]
| otherwise -- Not single-constructor
= case anal of
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 [absEvalAtom AbsAnal a env | a <- as]
+ if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
then AbsBot
else AbsTop
where
- (_,_,_, tycon) = getDataConSig con
- has_single_con = maybeToBool (maybeSingleConstructorTyCon tycon)
+ has_single_con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
\end{code}
\begin{code}
-absEval anal (Lam binder body) env
- = AbsFun [binder] body env
-absEval anal (CoTyLam ty expr) env
+absEval anal (Lam (ValBinder binder) body) env
+ = AbsFun binder body env
+absEval anal (Lam other_binder expr) env
= absEval anal expr env
-absEval anal (App e1 e2) env
- = absApply anal (absEval anal e1 env) (absEvalAtom anal e2 env)
-absEval anal (CoTyApp expr ty) env
+absEval anal (App f a) env | isValArg a
+ = absApply anal (absEval anal f env) (absEvalAtom anal a env)
+absEval anal (App expr _) env
= absEval anal expr env
\end{code}
{-
(case anal of
StrAnal -> id
- _ -> pprTrace "absCase:ABS:" (ppAbove (ppCat [ppr PprDebug expr, ppr PprDebug result, ppr PprDebug expr_val, ppr PprDebug abs_deflt, ppr PprDebug abs_alts]) (ppr PprDebug (keysFM env `zip` eltsFM env)))
+ _ -> pprTrace "absCase:ABS:" (($$) (hsep [ppr PprDebug expr, ppr PprDebug result, ppr PprDebug expr_val, ppr PprDebug abs_deflt, ppr PprDebug abs_alts]) (ppr PprDebug (keysFM env `zip` eltsFM env)))
)
-}
result
in
absEval anal body new_env
-absEval anal (SCC cc expr) env = absEval anal expr env
+absEval anal (SCC cc expr) env = absEval anal expr env
+absEval anal (Coerce c ty expr) env = absEval anal expr env
\end{code}
\begin{code}
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)
+absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr PprDebug f) <+> (ppr PprDebug arg))
#endif
\end{code}
See notes on @addStrictnessInfoToId@.
\begin{code}
-findStrictness :: StrAnalFlags
- -> [Type] -- Types of args in which strictness is wanted
+findStrictness :: [Type] -- Types of args in which strictness is wanted
-> AbsVal -- Abstract strictness value of function
-> AbsVal -- Abstract absence value of function
-> [Demand] -- Resulting strictness annotation
-findStrictness strflags [] str_val abs_val = []
+findStrictness [] str_val abs_val = []
-findStrictness strflags (ty:tys) str_val abs_val
+findStrictness (ty:tys) str_val abs_val
= let
- demand = findRecDemand strflags [] str_fn abs_fn ty
+ demand = findRecDemand [] str_fn abs_fn ty
str_fn val = absApply StrAnal str_val val
abs_fn val = absApply AbsAnal abs_val val
- demands = findStrictness strflags tys
+ demands = findStrictness tys
(absApply StrAnal str_val AbsTop)
(absApply AbsAnal abs_val AbsTop)
in
\begin{code}
findDemandStrOnly str_env expr binder -- Only strictness environment available
- = findRecDemand strflags [] str_fn abs_fn (idType binder)
+ = findRecDemand [] str_fn abs_fn (idType binder)
where
str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
abs_fn val = AbsBot -- Always says poison; so it looks as if
-- nothing is absent; safe
- strflags = getStrAnalFlags str_env
findDemandAbsOnly abs_env expr binder -- Only absence environment available
- = findRecDemand strflags [] str_fn abs_fn (idType binder)
+ = findRecDemand [] str_fn abs_fn (idType binder)
where
str_fn val = AbsBot -- Always says non-termination;
-- that'll make findRecDemand peer into the
-- structure of the value.
abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
- strflags = getStrAnalFlags abs_env
findDemand str_env abs_env expr binder
- = findRecDemand strflags [] str_fn abs_fn (idType 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)
- strflags = getStrAnalFlags str_env
\end{code}
@findRecDemand@ is where we finally convert strictness/absence info
Ho hum.
\begin{code}
-findRecDemand :: StrAnalFlags
- -> [TyCon] -- TyCons already seen; used to avoid
+findRecDemand :: [TyCon] -- TyCons already seen; used to avoid
-- zooming into recursive types
-> (AbsVal -> AbsVal) -- The strictness function
-> (AbsVal -> AbsVal) -- The absence function
-> Type -- The type of the argument
-> Demand
-findRecDemand strflags seen str_fn abs_fn ty
+findRecDemand seen str_fn abs_fn ty
= if isPrimType ty then -- It's a primitive type!
wwPrim
-- We prefer absence over strictness: see NOTE above.
WwLazy True
- else if not (all_strict ||
- (num_strict && is_numeric_type ty) ||
- (isBot (str_fn AbsBot))) then
+ else if not (opt_AllStrict ||
+ (opt_NumbersStrict && is_numeric_type ty) ||
+ (isBot (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 maybeDataTyCon ty of
+ case (maybeAppDataTyConExpandingDicts ty) of
Nothing -> wwStrict
Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen ->
-- Single constructor case, tycon not already seen higher up
+
let
- (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys
+ cmpnt_tys = dataConArgTys data_con tycon_arg_tys
prod_len = length cmpnt_tys
+ in
+ if isNewTyCon tycon then -- A newtype!
+ ASSERT( null (tail cmpnt_tys) )
+ let
+ demand = findRecDemand (tycon:seen) str_fn abs_fn (head cmpnt_tys)
+ in
+ case demand of -- No point in unpacking unless there is more to see inside
+ WwUnpack _ _ _ -> wwUnpackNew demand
+ other -> wwStrict
+
+ else -- A data type!
+ let
compt_strict_infos
- = [ findRecDemand strflags (tycon:seen)
+ = [ findRecDemand (tycon:seen)
(\ cmpnt_val ->
str_fn (mkMainlyTopProd prod_len i cmpnt_val)
)
if null compt_strict_infos then
if isEnumerationTyCon tycon then wwEnum else wwStrict
else
- wwUnpack compt_strict_infos
+ wwUnpackData compt_strict_infos
where
not_elem = isn'tIn "findRecDemand"
else
wwStrict
where
- (all_strict, num_strict) = strflags
-
is_numeric_type ty
- = case (maybeDataTyCon ty) of -- NB: duplicates stuff done above
+ = case (maybeAppDataTyConExpandingDicts ty) of -- NB: duplicates stuff done above
Nothing -> False
Just (tycon, _, _)
| tycon `is_elem`
projects / ghc-hetmet.git / blobdiff