Remove the (very) old strictness analyser

I finally got tired of the #ifdef OLD_STRICTNESS stuff.  I had been
keeping it around in the hope of doing old-to-new comparisions, but
have failed to do so for many years, so I don't think it's going to
happen.  This patch deletes the clutter.

1 files changed, 0 insertions, 317 deletions

diff --git a/compiler/cprAnalysis/CprAnalyse.lhs b/compiler/cprAnalysis/CprAnalyse.lhs
deleted file mode 100644
index 14c80176d4..0000000000
--- a/compiler/cprAnalysis/CprAnalyse.lhs
+++ /dev/null
@@ -1,317 +0,0 @@
-% (c) The University of Glasgow 2006
-
-\section[CprAnalyse]{Identify functions that always return a
-constructed product result}
-
-\begin{code}
-#ifndef OLD_STRICTNESS
-module CprAnalyse ( ) where
-
-#else
-
-module CprAnalyse ( cprAnalyse ) where
-
-#include "HsVersions.h"
-
-import DynFlags
-import CoreMonad
-import CoreSyn
-import CoreUtils
-import Id
-import IdInfo
-import Demand
-import VarEnv
-import Util
-import Outputable
-
-import Maybe
-\end{code}
-
-This module performs an analysis of a set of Core Bindings for the
-Constructed Product Result (CPR) transformation.
-
-It detects functions that always explicitly (manifestly?) construct a
-result value with a product type.  A product type is a type which has
-only one constructor. For example, tuples and boxed primitive values
-have product type.
-
-We must also ensure that the function's body starts with sufficient
-manifest lambdas otherwise loss of sharing can occur.  See the comment
-in @StrictAnal.lhs@.
-
-The transformation of bindings to worker/wrapper pairs is done by the
-worker-wrapper pass.  The worker-wrapper pass splits bindings on the
-basis of both strictness and CPR info.  If an id has both then it can
-combine the transformations so that only one pair is produced.
-
-The analysis here detects nested CPR information.  For example, if a
-function returns a constructed pair, the first element of which is a
-constructed int, then the analysis will detect nested CPR information
-for the int as well.  Unfortunately, the current transformations can't
-take advantage of the nested CPR information.  They have (broken now,
-I think) code which will flatten out nested CPR components and rebuild
-them in the wrapper, but enabling this would lose laziness.  It is
-possible to make use of the nested info: if we knew that a caller was
-strict in that position then we could create a specialized version of
-the function which flattened/reconstructed that position.
-
-It is not known whether this optimisation would be worthwhile.
-
-So we generate and carry round nested CPR information, but before
-using this info to guide the creation of workers and wrappers we map
-all components of a CPRInfo to NoCprInfo.
-
-
-Data types
-~~~~~~~~~~
-
-Within this module Id's CPR information is represented by
-``AbsVal''. When adding this information to the Id's pragma info field
-we convert the ``Absval'' to a ``CprInfo'' value.
-
-Abstract domains consist of a `no information' value (Top), a function
-value (Fun) which when applied to an argument returns a new AbsVal
-(note the argument is not used in any way), , for product types, a
-corresponding length tuple (Tuple) of abstract values.  And finally,
-Bot.  Bot is not a proper abstract value but a generic bottom is
-useful for calculating fixpoints and representing divergent
-computations.  Note that we equate Bot and Fun^n Bot (n > 0), and
-likewise for Top.  This saves a lot of delving in types to keep
-everything exactly correct.
-
-Since functions abstract to constant functions we could just
-represent them by the abstract value of their result.  However,  it
-turns out (I know - I tried!) that this requires a lot of type
-manipulation and the code is more straightforward if we represent
-functions by an abstract constant function.
-
-\begin{code}
-data AbsVal = Top                -- Not a constructed product
-
-            | Fun AbsVal         -- A function that takes an argument
-                                 -- and gives AbsVal as result.
-
-            | Tuple              -- A constructed product of values
-
-            | Bot                -- Bot'tom included for convenience
-                                 -- we could use appropriate Tuple Vals
-     deriving (Eq,Show)
-
--- For pretty debugging
-instance Outputable AbsVal where
-  ppr Top       = ptext (sLit "Top")
-  ppr (Fun r)   = ptext (sLit "Fun->") <> (parens.ppr) r
-  ppr Tuple     = ptext (sLit "Tuple ")
-  ppr Bot       = ptext (sLit "Bot")
-
-
--- lub takes the lowest upper bound of two abstract values, standard.
-lub :: AbsVal -> AbsVal -> AbsVal
-lub Bot a = a
-lub a Bot = a
-lub Top a = Top
-lub a Top = Top
-lub Tuple Tuple         = Tuple
-lub (Fun l) (Fun r)     = Fun (lub l r)
-lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple"
-
-
-\end{code}
-
-The environment maps Ids to their abstract CPR value.
-
-\begin{code}
-
-type CPREnv = VarEnv AbsVal
-
-initCPREnv = emptyVarEnv
-
-\end{code}
-
-Programs
-~~~~~~~~
-
-Take a list of core bindings and return a new list with CPR function
-ids decorated with their CprInfo pragmas.
-
-\begin{code}
-
-cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
-cprAnalyse dflags binds
-  = do {
-        showPass dflags "Constructed Product analysis" ;
-        let { binds_plus_cpr = do_prog binds } ;
-        endPass dflags "Constructed Product analysis"
-                Opt_D_dump_cpranal binds_plus_cpr []
-        return binds_plus_cpr
-    }
-  where
-    do_prog :: [CoreBind] -> [CoreBind]
-    do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds
-\end{code}
-
-The cprAnal functions take binds/expressions and an environment which
-gives CPR info for visible ids and returns a new bind/expression
-with ids decorated with their CPR info.
-
-\begin{code}
--- Return environment extended with info from this binding
-cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind)
-cprAnalBind rho (NonRec b e)
-  | isImplicitId b      -- Don't touch the CPR info on constructors, selectors etc
-  = (rho, NonRec b e)
-  | otherwise
-  = (extendVarEnv rho b absval, NonRec b' e')
-  where
-    (e', absval) = cprAnalExpr rho e
-    b' = addIdCprInfo b e' absval
-
-cprAnalBind rho (Rec prs)
-  = (final_rho, Rec (map do_pr prs))
-  where
-    do_pr (b,e) = (b', e')
-                where
-                  b'           = addIdCprInfo b e' absval
-                  (e', absval) = cprAnalExpr final_rho e
-
-        -- When analyzing mutually recursive bindings the iterations to find
-        -- a fixpoint is bounded by the number of bindings in the group.
-        -- for simplicity we just iterate that number of times.
-    final_rho = nTimes (length prs) do_one_pass init_rho
-    init_rho  = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs]
-
-    do_one_pass :: CPREnv -> CPREnv
-    do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
-                            rho prs
-
-
-cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
-
--- If Id will always diverge when given sufficient arguments then
--- we can just set its abs val to Bot.  Any other CPR info
--- from other paths will then dominate,  which is what we want.
--- Check in rho,  if not there it must be imported, so check
--- the var's idinfo.
-cprAnalExpr rho e@(Var v)
-    | isBottomingId v = (e, Bot)
-    | otherwise       = (e, case lookupVarEnv rho v of
-                             Just a_val -> a_val
-                             Nothing    -> getCprAbsVal v)
-
--- Literals are unboxed
-cprAnalExpr rho (Lit l) = (Lit l, Top)
-
--- For apps we don't care about the argument's abs val.  This
--- app will return a constructed product if the function does. We strip
--- a Fun from the functions abs val, unless the argument is a type argument
--- or it is already Top or Bot.
-cprAnalExpr rho (App fun arg@(Type _))
-    = (App fun_cpr arg, fun_res)
-    where
-      (fun_cpr, fun_res)  = cprAnalExpr rho fun
-
-cprAnalExpr rho (App fun arg)
-    = (App fun_cpr arg_cpr, res_res)
-    where
-      (fun_cpr, fun_res)  = cprAnalExpr rho fun
-      (arg_cpr, _)        = cprAnalExpr rho arg
-      res_res             = case fun_res of
-                                Fun res_res -> res_res
-                                Top         -> Top
-                                Bot         -> Bot
-                                Tuple       -> WARN( True, ppr (App fun arg) ) Top
-                                                -- This really should not happen!
-
-
--- Map arguments to Top (we aren't constructing them)
--- Return the abstract value of the body, since functions
--- are represented by the CPR value of their result, and
--- add a Fun for this lambda..
-cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
-                             | otherwise = (Lam b body_cpr, Fun body_aval)
-      where
-      (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
-
-cprAnalExpr rho (Let bind body)
-    = (Let bind' body', body_aval)
-    where
-      (rho', bind') = cprAnalBind rho bind
-      (body', body_aval) = cprAnalExpr rho' body
-
-cprAnalExpr rho (Case scrut bndr alts)
-    = (Case scrut_cpr bndr alts_cpr, alts_aval)
-      where
-      (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
-      (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
-
-cprAnalExpr rho (Note n exp)
-    = (Note n exp_cpr, expr_aval)
-      where
-      (exp_cpr, expr_aval) = cprAnalExpr rho exp
-
-cprAnalExpr rho (Type t)
-    = (Type t, Top)
-
-cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
-cprAnalCaseAlts rho alts
-    = foldr anal_alt ([], Bot) alts
-      where
-      anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal)
-      anal_alt (con, binds, exp)  (done, aval)
-          = ((con,binds,exp_cpr) : done, exp_aval `lub` aval)
-            where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
-                  rho' = rho `extendVarEnvList` (zip binds (repeat Top))
-
-
-addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
-addIdCprInfo bndr rhs absval
-  | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
-  | otherwise                = bndr
-  where
-    cpr_info    = absToCprInfo absval
-    useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False }
-
-    ok_to_add = case absval of
-                  Fun _ -> idArity bndr >= n_fun_tys absval
-                      -- Enough visible lambdas
-
-                  Tuple  -> exprIsHNF rhs || isStrict (idDemandInfo bndr)
-                        -- If the rhs is a value, and returns a constructed product,
-                        -- it will be inlined at usage sites, so we give it a Tuple absval
-                        -- If it isn't a value, we won't inline it (code/work dup worries), so
-                        -- we discard its absval.
-                        --
-                        -- Also, if the strictness analyser has figured out that it's strict,
-                        -- the let-to-case transformation will happen, so again it's good.
-                        -- (CPR analysis runs before the simplifier has had a chance to do
-                        --  the let-to-case transform.)
-                        -- This made a big difference to PrelBase.modInt, which had something like
-                        --      modInt = \ x -> let r = ... -> I# v in
-                        --                      ...body strict in r...
-                        -- r's RHS isn't a value yet; but modInt returns r in various branches, so
-                        -- if r doesn't have the CPR property then neither does modInt
-
-                  _ -> False
-
-    n_fun_tys :: AbsVal -> Int
-    n_fun_tys (Fun av) = 1 + n_fun_tys av
-    n_fun_tys other    = 0
-
-
-absToCprInfo :: AbsVal -> CprInfo
-absToCprInfo Tuple   = ReturnsCPR
-absToCprInfo (Fun r) = absToCprInfo r
-absToCprInfo _       = NoCPRInfo
-
-
--- Cpr Info doesn't store the number of arguments a function has,  so the caller
--- must take care to add the appropriate number of Funs.
-getCprAbsVal v = case idCprInfo v of
-                        NoCPRInfo -> Top
-                        ReturnsCPR -> nTimes arity Fun Tuple
-               where
-                 arity = idArity v
-        -- Imported (non-nullary) constructors will have the CPR property
-        -- in their IdInfo, so no need to look at their unfolding
-#endif /* OLD_STRICTNESS */
-\end{code}