X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=10f5e4221a8130acf089be09bd24128e323bbfbe;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=9cdb3d4164af1b5d1366140cf5fae79d175147ff;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 9cdb3d4..10f5e42 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[SaAbsInt]{Abstract interpreter for strictness analysis} @@ -15,31 +15,36 @@ module SaAbsInt ( isBot ) where -IMPORT_Trace -- ToDo: rm -import Pretty ---import FiniteMap -import Outputable - -import AbsPrel ( PrimOp(..), PrimKind ) -import AbsUniType ( isPrimType, getUniDataTyCon_maybe, - maybeSingleConstructorTyCon, - returnsRealWorld, - isEnumerationTyCon, TyVarTemplate, TyCon - IF_ATTACK_PRAGMAS(COMMA cmpTyCon) +IMP_Ubiq(){-uitous-} + +import CoreSyn +import CoreUnfold ( UnfoldingDetails(..), FormSummary ) +import CoreUtils ( unTagBinders ) +import Id ( idType, getIdStrictness, getIdUnfolding, + dataConTyCon, dataConArgTys ) -import Id ( getIdStrictness, getIdUniType, getIdUnfolding, - getDataConSig, getInstantiatedDataConSig, - DataCon(..), isBottomingId +import IdInfo ( StrictnessInfo(..), Demand(..), + wwPrim, wwStrict, wwEnum, wwUnpack ) - -import IdInfo -- various bits -import IdEnv -import CoreFuns ( unTagBinders ) -import Maybes ( maybeToBool, Maybe(..) ) -import PlainCore +import MagicUFs ( MagicUnfoldingFun ) +import Maybes ( maybeToBool ) +import Outputable ( Outputable(..){-instance * []-} ) +import PprStyle ( PprStyle(..) ) +import Pretty ( ppStr ) +import PrimOp ( PrimOp(..) ) import SaLib -import SimplEnv ( FormSummary(..) ) -- nice data abstraction, huh? (WDP 95/03) -import Util +import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, + TyCon{-instance Eq-} + ) +import Type ( maybeAppDataTyConExpandingDicts, isPrimType ) +import TysWiredIn ( intTyCon, integerTyCon, doubleTyCon, + floatTyCon, wordTyCon, addrTyCon + ) +import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, + pprTrace, panic, pprPanic, assertPanic + ) + +returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)" \end{code} %************************************************************************ @@ -58,11 +63,10 @@ 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 (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys) - AbsProd (zipWith 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 + -- The crudity only shows up if there -- are functions involved -- Slightly funny glb; for absence analysis only; @@ -73,7 +77,7 @@ lub _ _ = AbsTop -- Crude, but conservative -- -- f = \a b -> ... -- --- g = \x y z -> case x of +-- g = \x y z -> case x of -- [] -> f x -- (p:ps) -> f p -- @@ -101,9 +105,9 @@ lub _ _ = AbsTop -- Crude, but conservative -- Deal with functions specially, because AbsTop isn't the -- top of their domain. -glb v1 v2 +glb v1 v2 | is_fun v1 || is_fun v2 - = if not (anyBot v1) && not (anyBot v2) + = if not (anyBot v1) && not (anyBot v2) then AbsTop else @@ -115,8 +119,7 @@ glb v1 v2 -- The non-functional cases are quite straightforward -glb (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys) - AbsProd (zipWith glb xs ys) +glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys) glb AbsTop v2 = v2 glb v1 AbsTop = v1 @@ -125,7 +128,7 @@ glb _ _ = AbsBot -- Be pessimistic -combineCaseValues +combineCaseValues :: AnalysisKind -> AbsVal -- Value of scrutinee -> [AbsVal] -- Value of branches (at least one) @@ -145,7 +148,7 @@ combineCaseValues StrAnal other_scrutinee branches AbsTop -> True; -- i.e., cool AbsProd _ -> True; -- ditto _ -> False -- party over - } + } -- For absence analysis, check if the scrutinee is all poison (isBot) -- If so, return poison (AbsBot); otherwise, any nested poison will come @@ -196,8 +199,8 @@ isBot :: AbsVal -> Bool isBot AbsBot = True isBot (AbsFun args body env) = isBot (absEval StrAnal body env) - -- Don't bother to extend the envt because - -- unbound variables default to AbsTop anyway + -- Don't bother to extend the envt because + -- unbound variables default to AbsTop anyway isBot other = False \end{code} @@ -223,7 +226,7 @@ it, so it can be compared for equality by @sameVal@. \begin{code} widen :: AnalysisKind -> AbsVal -> AbsVal -widen StrAnal (AbsFun args body env) +widen StrAnal (AbsFun args body env) | isBot (absEval StrAnal body env) = AbsBot | otherwise = ASSERT (not (null args)) @@ -244,12 +247,12 @@ widen StrAnal (AbsFun args body env) -- 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) +widen AbsAnal (AbsFun args body env) | anyBot (absEval AbsAnal body env) = AbsBot -- In the absence-analysis case it's *essential* to check -- that the function has no poison in its body. If it does, @@ -258,7 +261,7 @@ widen AbsAnal (AbsFun args body env) | otherwise = ASSERT (not (null args)) AbsApproxFun (map (findDemandAbsOnly env body) args) - + widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) -- It's desirable to do a good job of widening for product @@ -276,7 +279,7 @@ widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) widen AbsAnal other_val = other_val --- OLD if anyBot val then AbsBot else AbsTop +-- WAS: if anyBot val then AbsBot else AbsTop -- Nowadays widen is doing a better job on functions for absence analysis. \end{code} @@ -305,8 +308,7 @@ sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot sameVal AbsTop AbsTop = True sameVal AbsTop other = False -- Right? -sameVal (AbsProd vals1) (AbsProd vals2) = ASSERT (length vals1 == length vals2) - and (zipWith sameVal vals1 vals2) +sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2) sameVal (AbsProd _) AbsTop = False sameVal (AbsProd _) AbsBot = False @@ -323,9 +325,9 @@ sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered" (@True@ is the exciting answer; @False@ is always safe.) \begin{code} -evalStrictness :: Demand - -> AbsVal - -> Bool -- True iff the value is sure +evalStrictness :: Demand + -> AbsVal + -> Bool -- True iff the value is sure -- to be less defined than the Demand evalStrictness (WwLazy _) _ = False @@ -336,15 +338,14 @@ evalStrictness (WwUnpack demand_info) val = case val of AbsTop -> False AbsBot -> True - AbsProd vals -> ASSERT (length vals == length demand_info) - or (zipWith evalStrictness demand_info vals) + AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals) _ -> trace "evalStrictness?" False evalStrictness WwPrim val = case val of - AbsTop -> False + AbsTop -> False - other -> -- A primitive value should be defined, never bottom; + other -> -- A primitive value should be defined, never bottom; -- hence this paranoia check pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other) \end{code} @@ -355,15 +356,14 @@ function call; that is, whether the specified demand can {\em possibly} hit poison. \begin{code} -evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison +evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison -- with Absent demand evalAbsence (WwUnpack demand_info) val = case val of AbsTop -> False -- No poison in here AbsBot -> True -- Pure poison - AbsProd vals -> ASSERT (length demand_info == length vals) - or (zipWith evalAbsence demand_info vals) + AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals) _ -> panic "evalAbsence: other" evalAbsence other val = anyBot val @@ -390,17 +390,10 @@ absId anal var env result = case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of - (Just abs_val, _, _) -> + (Just abs_val, _, _) -> abs_val -- Bound in the environment - (Nothing, NoStrictnessInfo, LiteralForm _) -> - AbsTop -- Literals all terminate, and have no poison - - (Nothing, NoStrictnessInfo, ConstructorForm _ _ _) -> - AbsTop -- An imported constructor won't have - -- bottom components, nor poison! - - (Nothing, NoStrictnessInfo, GeneralForm _ _ unfolding _) -> + (Nothing, NoStrictnessInfo, GenForm _ unfolding _) -> -- We have an unfolding for the expr -- Assume the unfolding has no free variables since it -- came from inside the Id @@ -425,32 +418,27 @@ absId anal var env -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} - (Nothing, strictness_info, _) -> + (Nothing, strictness_info, _) -> -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails -- Try the strictness info absValFromStrictness anal strictness_info - - - -- Done via strictness now - -- GeneralForm _ BottomForm _ _ -> AbsBot in - -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) ( + -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) $ result - -- ) where pp_anal StrAnal = ppStr "STR" pp_anal AbsAnal = ppStr "ABS" -absEvalAtom anal (CoVarAtom v) env = absId anal v env -absEvalAtom anal (CoLitAtom _) env = AbsTop +absEvalAtom anal (VarArg v) env = absId anal v env +absEvalAtom anal (LitArg _) env = AbsTop \end{code} \begin{code} -absEval :: AnalysisKind -> PlainCoreExpr -> AbsValEnv -> AbsVal +absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal -absEval anal (CoVar var) env = absId anal var env +absEval anal (Var var) env = absId anal var env -absEval anal (CoLit _) env = AbsTop +absEval anal (Lit _) env = AbsTop -- What if an unboxed literal? That's OK: it terminates, so its -- abstract value is AbsTop. @@ -480,12 +468,13 @@ Things are a little different for absence analysis, because we want to make sure that any poison (?????) \begin{code} -absEval StrAnal (CoPrim 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 (CoPrim 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. @@ -496,44 +485,45 @@ absEval StrAnal (CoPrim op ts es) env = AbsTop -- uses boxed args and we don't know whether or not it's -- strict, so we assume laziness. (JSM) -absEval AbsAnal (CoPrim 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 (CoCon con ts as) env +absEval anal (Con con as) env | has_single_con - = AbsProd [absEvalAtom anal a env | a <- as] + = AbsProd [absEvalAtom anal a env | a <- as, 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 + 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 [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 (CoLam [] body) env = absEval anal body env -- paranoia -absEval anal (CoLam binders body) env = AbsFun binders body env -absEval anal (CoTyLam ty expr) env = absEval anal expr env -absEval anal (CoApp e1 e2) env = absApply anal (absEval anal e1 env) - (absEvalAtom anal e2 env) -absEval anal (CoTyApp expr ty) env = absEval anal 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 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} For primitive cases, just GLB the branches, then LUB with the expr part. \begin{code} -absEval anal (CoCase expr (CoPrimAlts alts deflt)) env +absEval anal (Case expr (PrimAlts alts deflt)) env = let expr_val = absEval anal expr env abs_alts = [ absEval anal rhs env | (_, rhs) <- alts ] @@ -545,9 +535,9 @@ absEval anal (CoCase expr (CoPrimAlts alts deflt)) env combineCaseValues anal expr_val (abs_deflt ++ abs_alts) -absEval anal (CoCase expr (CoAlgAlts alts deflt)) env +absEval anal (Case expr (AlgAlts alts deflt)) env = let - expr_val = absEval anal expr env + expr_val = absEval anal expr env abs_alts = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ] abs_deflt = absEvalDefault anal expr_val deflt env in @@ -565,7 +555,7 @@ absEval anal (CoCase expr (CoAlgAlts alts deflt)) env result \end{code} -For @CoLets@ we widen the value we get. This is nothing to +For @Lets@ we widen the value we get. This is nothing to do with fixpointing. The reason is so that we don't get an explosion in the amount of computation. For example, consider: \begin{verbatim} @@ -576,7 +566,7 @@ in the amount of computation. For example, consider: f x = case x of p1 -> ...g r... p2 -> ...g s... - in + in f e \end{verbatim} If we bind @f@ and @g@ to their exact abstract value, then we'll @@ -590,31 +580,28 @@ alternative approach would be to try with a certain amount of ``fuel'' and be prepared to bale out. \begin{code} -absEval anal (CoLet (CoNonRec binder e1) e2) env +absEval anal (Let (NonRec binder e1) e2) env = let new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env)) in - -- The binder of a CoNonRec should *not* be of unboxed type, + -- The binder of a NonRec should *not* be of unboxed type, -- hence no need to strictly evaluate the Rhs. absEval anal e2 new_env -absEval anal (CoLet (CoRec pairs) body) env +absEval anal (Let (Rec pairs) body) env = let (binders,rhss) = unzip pairs rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values new_env = growAbsValEnvList env (binders `zip` rhs_vals) in absEval anal body new_env -\end{code} -\begin{code} -absEval anal (CoSCC cc expr) env = absEval anal expr env - --- ToDo: add DPH stuff here +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} -absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],PlainCoreExpr) -> AbsValEnv -> AbsVal +absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env = -- The scrutinee is a product value, so it must be of a single-constr @@ -642,15 +629,15 @@ absEvalAlgAlt anal other_scrutinee (con, args, rhs) env _ -> False -- party over } - -absEvalDefault :: AnalysisKind + +absEvalDefault :: AnalysisKind -> AbsVal -- Value of scrutinee - -> PlainCoreCaseDefault - -> AbsValEnv + -> CoreCaseDefault + -> AbsValEnv -> [AbsVal] -- Empty or singleton -absEvalDefault anal scrut_val CoNoDefault env = [] -absEvalDefault anal scrut_val (CoBindDefault binder expr) env +absEvalDefault anal scrut_val NoDefault env = [] +absEvalDefault anal scrut_val (BindDefault binder expr) env = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)] \end{code} @@ -669,7 +656,7 @@ absApply anal AbsBot arg = AbsBot -- AbsBot represents the abstract bottom *function* too absApply StrAnal AbsTop arg = AbsTop -absApply AbsAnal AbsTop arg = if anyBot arg +absApply AbsAnal AbsTop arg = if anyBot arg then AbsBot else AbsTop -- To be conservative, we have to assume that a function about @@ -678,7 +665,7 @@ absApply AbsAnal AbsTop arg = if anyBot arg \end{code} An @AbsFun@ with only one more argument needed---bind it and eval the -result. A @CoLam@ with two or more args: return another @AbsFun@ with +result. A @Lam@ with two or more args: return another @AbsFun@ with an augmented environment. \begin{code} @@ -736,51 +723,53 @@ unbound variables in an @AbsValEnv@ are implicitly mapped to that. See notes on @addStrictnessInfoToId@. \begin{code} -findStrictness :: [UniType] -- Types of args in which strictness is wanted - -> AbsVal -- Abstract strictness value of function +findStrictness :: StrAnalFlags + -> [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 [] str_val abs_val = [] +findStrictness strflags [] str_val abs_val = [] -findStrictness (ty:tys) str_val abs_val +findStrictness strflags (ty:tys) str_val abs_val = let - demand = findRecDemand [] str_fn abs_fn ty + demand = findRecDemand strflags [] str_fn abs_fn ty str_fn val = absApply StrAnal str_val val abs_fn val = absApply AbsAnal abs_val val - demands = findStrictness tys (absApply StrAnal str_val AbsTop) - (absApply AbsAnal abs_val AbsTop) + demands = findStrictness strflags tys + (absApply StrAnal str_val AbsTop) + (absApply AbsAnal abs_val AbsTop) in - -- pprTrace "findRecDemand:" (ppCat [ppr PprDebug demand, ppr PprDebug ty]) ( demand : demands - -- ) \end{code} \begin{code} findDemandStrOnly str_env expr binder -- Only strictness environment available - = findRecDemand [] str_fn abs_fn (getIdUniType binder) + = findRecDemand strflags [] 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 [] str_fn abs_fn (getIdUniType binder) + = findRecDemand strflags [] 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 [] str_fn abs_fn (getIdUniType binder) + = findRecDemand strflags [] 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 @@ -816,14 +805,15 @@ then we'd let-to-case it: Ho hum. \begin{code} -findRecDemand :: [TyCon] -- TyCons already seen; used to avoid +findRecDemand :: StrAnalFlags + -> [TyCon] -- TyCons already seen; used to avoid -- zooming into recursive types -> (AbsVal -> AbsVal) -- The strictness function -> (AbsVal -> AbsVal) -- The absence function - -> UniType -- The type of the argument + -> Type -- The type of the argument -> Demand -findRecDemand seen str_fn abs_fn ty +findRecDemand strflags seen str_fn abs_fn ty = if isPrimType ty then -- It's a primitive type! wwPrim @@ -831,23 +821,25 @@ findRecDemand seen str_fn abs_fn ty -- We prefer absence over strictness: see NOTE above. WwLazy True - else if not (isBot (str_fn AbsBot)) then -- It's not strict - WwLazy False + else if not (all_strict || + (num_strict && is_numeric_type ty) || + (isBot (str_fn AbsBot))) then + WwLazy False -- It's not strict and we're not pretending - else -- It's strict! + else -- It's strict (or we're pretending it is)! - case getUniDataTyCon_maybe 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 compt_strict_infos - = [ findRecDemand (tycon:seen) + = [ findRecDemand strflags (tycon:seen) (\ cmpnt_val -> str_fn (mkMainlyTopProd prod_len i cmpnt_val) ) @@ -874,6 +866,21 @@ findRecDemand seen str_fn abs_fn ty else wwStrict where + (all_strict, num_strict) = strflags + + is_numeric_type ty + = case (maybeAppDataTyConExpandingDicts ty) of -- NB: duplicates stuff done above + Nothing -> False + Just (tycon, _, _) + | tycon `is_elem` + [intTyCon, integerTyCon, + doubleTyCon, floatTyCon, + wordTyCon, addrTyCon] + -> True + _{-something else-} -> False + where + is_elem = isIn "is_numeric_type" + -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of -- them) except for a given value in the "i"th position. @@ -902,7 +909,7 @@ That allows us to make rapid progress, at the cost of a less-than-wonderful approximation. \begin{code} -cheapFixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal] +cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal] cheapFixpoint AbsAnal [id] [rhs] env = [crudeAbsWiden (absEval AbsAnal rhs new_env)] @@ -924,7 +931,7 @@ cheapFixpoint anal ids rhss env = [widen anal (absEval anal rhs new_env) | rhs <- rhss] -- We do just one iteration, starting from a safe -- approximation. This won't do a good job in situations - -- like: + -- like: -- \x -> letrec f = ...g... -- g = ...f...x... -- in @@ -956,16 +963,16 @@ mkLookupFun eq lt alist s \end{verbatim} \begin{code} -fixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal] +fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal] fixpoint anal [] _ env = [] -fixpoint anal ids rhss env +fixpoint anal ids rhss env = fix_loop initial_vals where initial_val id = case anal of -- The (unsafe) starting point - StrAnal -> if (returnsRealWorld (getIdUniType id)) + StrAnal -> if (returnsRealWorld (idType id)) then AbsTop -- this is a massively horrible hack (SLPJ 95/05) else AbsBot AbsAnal -> AbsTop @@ -974,15 +981,18 @@ fixpoint anal ids rhss env fix_loop :: [AbsVal] -> [AbsVal] - fix_loop current_widened_vals + fix_loop current_widened_vals = let new_env = growAbsValEnvList env (ids `zip` current_widened_vals) new_vals = [ absEval anal rhs new_env | rhs <- rhss ] new_widened_vals = map (widen anal) new_vals - in + in if (and (zipWith sameVal current_widened_vals new_widened_vals)) then current_widened_vals + -- NB: I was too chicken to make that a zipWithEqual, + -- lest I jump into a black hole. WDP 96/02 + -- Return the widened values. We might get a slightly -- better value by returning new_vals (which we used to -- do, see below), but alas that means that whenever the @@ -1011,7 +1021,7 @@ isn't safe). Why isn't @AbsTop@ safe? Consider: letrec x = ...p..d... d = (x,y) - in + in ... \end{verbatim} Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed