-
-%************************************************************************
-%* *
-\subsection{Miscellaneous
-%* *
-%************************************************************************
-
-
-\begin{code}
-#ifdef OLD_STRICTNESS
-get_changes binds = vcat (map get_changes_bind binds)
-
-get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
-get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
-
-get_changes_pr (id,rhs)
- = get_changes_var id $$ get_changes_expr rhs
-
-get_changes_var var
- | isId var = get_changes_str var $$ get_changes_dmd var
- | otherwise = empty
-
-get_changes_expr (Type t) = empty
-get_changes_expr (Var v) = empty
-get_changes_expr (Lit l) = empty
-get_changes_expr (Note n e) = get_changes_expr e
-get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
-get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
-get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
-get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
-
-get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
-
-get_changes_str id
- | new_better && old_better = empty
- | new_better = message "BETTER"
- | old_better = message "WORSE"
- | otherwise = message "INCOMPARABLE"
- where
- message word = text word <+> text "strictness for" <+> ppr id <+> info
- info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old
- -- strictness analyser can't track
- old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
- old_better = old `betterStrictness` new
- new_better = new `betterStrictness` old
-
-get_changes_dmd id
- | isUnLiftedType (idType id) = empty -- Not useful
- | new_better && old_better = empty
- | new_better = message "BETTER"
- | old_better = message "WORSE"
- | otherwise = message "INCOMPARABLE"
- where
- message word = text word <+> text "demand for" <+> ppr id <+> info
- info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements
- -- A bit of a hack
- old = newDemand (idDemandInfo id)
- new_better = new `betterDemand` old
- old_better = old `betterDemand` new
-
-betterStrictness :: StrictSig -> StrictSig -> Bool
-betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
-
-betterDmdType t1 t2 = (t1 `lubType` t2) == t2
-
-betterDemand :: Demand -> Demand -> Bool
--- If d1 `better` d2, and d2 `better` d2, then d1==d2
-betterDemand d1 d2 = (d1 `lub` d2) == d2
-
-squashSig (StrictSig (DmdType fv ds res))
- = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
- where
- -- squash just gets rid of call demands
- -- which the old analyser doesn't track
-squashDmd (Call d) = evalDmd
-squashDmd (Box d) = Box (squashDmd d)
-squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
-squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)
-squashDmd d = d
-#endif
-\end{code}