X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=3cd9ba434b6533661886c1f0293f7c32433e7d20;hb=6ee7389261b6559c3507b90b9476aa8daf45400c;hp=bec1d11fcd33b56b9c8f995ae75d1281dd48ded7;hpb=cfbedcecad9f9c4241fa1313e73468fd95db76b3;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index bec1d11..3cd9ba4 100644 --- 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} +#ifndef OLD_STRICTNESS +-- If OLD_STRICTNESS is off, omit all exports +module SaAbsInt () where + +#else module SaAbsInt ( findStrictness, findDemand, findDemandAlts, @@ -17,20 +22,22 @@ module SaAbsInt ( import CmdLineOpts ( 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} @@ -284,15 +291,16 @@ evalStrictness (WwLazy _) _ = False 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 @@ -312,15 +320,17 @@ possibly} hit poison. 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 @@ -343,7 +353,7 @@ evalAbsence other val = anyBot val absId anal var env = case (lookupAbsValEnv env var, - isDataConId_maybe var, + isDataConWorkId_maybe var, idStrictness var, maybeUnfoldingTemplate (idUnfolding var)) of @@ -456,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. - ASSERT(length arg_vals == length val_bndrs) + ASSERT(equalLength arg_vals val_bndrs) absEval anal rhs rhs_env where val_bndrs = filter isId bndrs @@ -506,6 +516,11 @@ absEval anal (Let (Rec pairs) body) 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} @@ -602,9 +617,11 @@ findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) -- 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 @@ -616,16 +633,22 @@ findStrictness id str_val abs_val = NoStrictnessInfo -- 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} @@ -704,19 +727,15 @@ findRecDemand str_fn abs_fn ty -- 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 @@ -733,12 +752,9 @@ findRecDemand str_fn abs_fn ty 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" @@ -810,19 +826,6 @@ cheapFixpoint anal ids rhss env 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] @@ -916,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. + +\begin{code} +#endif /* OLD_STRICTNESS */ +\end{code}