ghc/compiler/cprAnalysis/CprAnalyse.lhs

   1 \section[CprAnalyse]{Identify functions that always return a
   2 constructed product result}
   3
   4 \begin{code}
   5 module CprAnalyse ( cprAnalyse ) where
   6
   7 #include "HsVersions.h"
   8
   9 import CmdLineOpts      ( opt_D_verbose_core2core, opt_D_dump_cpranal )
  10 import CoreLint         ( beginPass, endPass )
  11 import CoreSyn
  12 import CoreUtils        ( coreExprType )
  13 import CoreUnfold       ( maybeUnfoldingTemplate )
  14 import Var              ( Var, Id, TyVar, idType, varName, varType )
  15 import Id               ( setIdCprInfo, getIdCprInfo, getIdUnfolding )
  16 import IdInfo           ( CprInfo(..) )
  17 import VarEnv
  18 import Type             ( Type(..), splitFunTys, splitForAllTys, splitNewType_maybe )
  19 import TyCon            ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
  20 import DataCon          ( dataConTyCon, splitProductType_maybe )
  21 import Const            ( Con(DataCon), isWHNFCon )
  22 import Util             ( zipEqual, zipWithEqual )
  23 import Outputable
  24
  25 import UniqFM (ufmToList)
  26
  27 \end{code}
  28
  29 This module performs an analysis of a set of Core Bindings for the
  30 Constructed Product Result (CPR) transformation.
  31
  32 It detects functions that always explicitly (manifestly?) construct a
  33 result value with a product type.  A product type is a type which has
  34 only one constructor. For example, tuples and boxed primitive values
  35 have product type.
  36
  37 We must also ensure that the function's body starts with sufficient
  38 manifest lambdas otherwise loss of sharing can occur.  See the comment
  39 in @StrictAnal.lhs@.
  40
  41 The transformation of bindings to worker/wrapper pairs is done by the
  42 worker-wrapper pass.  The worker-wrapper pass splits bindings on the
  43 basis of both strictness and CPR info.  If an id has both then it can
  44 combine the transformations so that only one pair is produced.
  45
  46 Data types
  47 ~~~~~~~~~~
  48
  49 Within this module Id's CPR information is represented by
  50 ``AbsVal''. When adding this information to the Id's pragma info field
  51 we convert the Absval to a ``CprInfo'' value.  The two are almost
  52 isomorphic, CprInfo doesn't have a represenation for Bot.
  53
  54 Abstract domains consist of a `no information' value (Top) and
  55 for tuple types, a corresponding length tuple of abstract values.
  56 Bot is not a proper abstract value but a generic bottom is
  57 useful for calculating fixpoints.
  58
  59 Since functions abstract to constant functions we can just
  60 represent their result.  It is not necessary to model functions
  61 directly.  This is more efficient,  but unfortunately it both
  62 simplifies and pbscures the code in places.
  63
  64 \begin{code}
  65 data AbsVal = Top                -- Not a constructed product
  66             | Tuple [AbsVal]     -- A constructed product of values
  67             | Bot                -- Bot'tom included for convenience
  68                                  -- we could use appropriate Tuple Vals
  69      deriving Show
  70
  71 -- For pretty debugging
  72 instance Outputable AbsVal where
  73   ppr Top                       = ptext SLIT("Top")
  74   ppr (Tuple la)                = ptext SLIT("Tuple ") <> text "[" <>
  75                                   (hsep (punctuate comma (map ppr la))) <>
  76                                   text "]"
  77   ppr Bot                       = ptext SLIT("Bot")
  78
  79 lub :: AbsVal -> AbsVal -> AbsVal
  80 lub Bot a = a
  81 lub a Bot = a
  82 lub Top a = Top
  83 lub a Top = Top
  84 lub (Tuple l) (Tuple r) = Tuple (zipWithEqual "CPR: lub" lub l r)
  85
  86 \end{code}
  87
  88 The environment maps Ids to their abstract CPR value.
  89
  90 \begin{code}
  91
  92 type CPREnv = VarEnv AbsVal
  93
  94 initCPREnv = emptyVarEnv
  95
  96 \end{code}
  97
  98 Programs
  99 ~~~~~~~~
 100
 101 Take a list of core bindings and return a new list with CPR function
 102 ids decorated with their CprInfo pragmas.
 103
 104 \begin{code}
 105
 106 cprAnalyse :: [CoreBind]
 107                  -> IO [CoreBind]
 108 cprAnalyse binds
 109   = do {
 110         beginPass "Constructed Product analysis" ;
 111         let { binds_plus_cpr = do_prog binds } ;
 112         endPass "Constructed Product analysis"
 113                 (opt_D_dump_cpranal || opt_D_verbose_core2core)
 114                 binds_plus_cpr
 115     }
 116   where
 117     do_prog :: [CoreBind] -> [CoreBind]
 118     do_prog binds
 119         = snd $ foldl analBind (initCPREnv, []) binds
 120         where
 121         analBind :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind])
 122         analBind (rho,done_binds) bind
 123             = (extendVarEnvList rho env, done_binds ++ [bind'])
 124               where
 125               (env, bind') = cprAnalTopBind rho bind
 126
 127 \end{code}
 128
 129 The cprAnal functions take binds/expressions and an environment which
 130 gives CPR info for visible ids and returns a new bind/expression
 131 with ids decorated with their CPR info.
 132
 133 \begin{code}
 134 -- Return environment updated with info from this binding
 135 cprAnalTopBind :: CPREnv -> CoreBind -> ([(Var, AbsVal)], CoreBind)
 136 cprAnalTopBind rho (NonRec v e)
 137     = ([(v', e_absval')], NonRec v' e_pluscpr)
 138       where
 139       (e_pluscpr, e_absval) = cprAnalExpr rho e
 140       (v', e_absval')       = pinCPR v e e_absval
 141
 142 -- When analyzing mutually recursive bindings the iterations to find
 143 -- a fixpoint is bounded by the number of bindings in the group.
 144 -- for simplicity we just iterate that number of times.
 145 cprAnalTopBind rho (Rec bounders)
 146     = (map (\(b,e) -> (b, lookupVarEnv_NF fin_rho b)) fin_bounders',
 147        Rec fin_bounders')
 148       where
 149       init_rho = rho `extendVarEnvList`  (zip binders (repeat Bot))
 150       binders = map fst bounders
 151
 152       (fin_rho, fin_bounders) = ntimes (length bounders)
 153                                        do_one_pass
 154                                        (init_rho, bounders)
 155       fin_bounders' = map (\(b,e) -> (fst $ pinCPR b e (lookupVarEnv_NF fin_rho b), e))
 156                       fin_bounders
 157
 158 cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
 159
 160 -- Check in rho,  if not there it must be imported, so check
 161 -- the var's idinfo.
 162 cprAnalExpr rho e@(Var v)
 163     = (e, case lookupVarEnv rho v of
 164             Just a_val -> a_val
 165             Nothing    -> getCprPragInfo v)
 166     where
 167     getCprPragInfo v = let ids_inf = (cprInfoToAbs . getIdCprInfo) v in
 168                          case ids_inf of
 169                          Top -> -- if we can inline this var,  then
 170                               -- analyse the unfolding
 171                               case (maybeUnfoldingTemplate.getIdUnfolding) v of
 172                                 Just e ->  if isCon e then snd $ cprAnalExpr rho e
 173                                            else ids_inf
 174                                 zz_other -> ids_inf
 175                          zz_other -> ids_inf
 176
 177 -- Return constructor with decorated arguments.  If constructor
 178 -- has product type then this is a manifest constructor (hooray!)
 179 cprAnalExpr rho (Con con args)
 180     = (Con con args_cpr,
 181        -- Don't need to do this here,  since we will filter out later
 182        -- but it isn't expensive and will reduce returned abs vals.
 183        if isConProdType con
 184          then Tuple args_avals
 185          else Top)
 186     where
 187     (args_cpr, args_avals) = foldl anal_arg ([], []) args
 188
 189     anal_arg :: ([CoreExpr], [AbsVal]) -> CoreExpr -> ([CoreExpr], [AbsVal])
 190     anal_arg (done_args, avs) arg
 191         | isValArg arg = cprAnalExpr rho arg `end_cons` (done_args, avs)
 192         | otherwise = (done_args ++ [arg], avs)
 193         where
 194         end_cons :: (a,b) -> ([a],[b]) -> ([a],[b])
 195         end_cons (x,y) (xs,ys) = (xs ++ [x], ys ++ [y])
 196
 197 -- For apps we ignore the argument.  This app will return a constructed
 198 -- product if the function does (we check that result type is not a fn when
 199 -- we come to decorate a binder).
 200 cprAnalExpr rho (App fun arg)
 201     = (App fun_cpr arg_cpr, res_aval)
 202       where
 203       (fun_cpr, res_aval) = cprAnalExpr rho fun
 204       (arg_cpr, arg_aval) = cprAnalExpr rho arg
 205
 206 -- Map arguments to Top (we aren't constructing them)
 207 -- Return the abstract value of the body, since functions
 208 -- are represented by the CPR value of their result.
 209 cprAnalExpr rho (Lam b body)
 210     = (Lam b body_cpr, body_aval)
 211       where
 212       (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
 213
 214 cprAnalExpr rho (Let (NonRec binder rhs) body)
 215     = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval)
 216       where
 217       (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs
 218       (binder', rhs_aval') = pinCPR binder rhs_cpr rhs_aval
 219       (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval') body
 220
 221 cprAnalExpr rho (Let (Rec bounders) body)
 222     = (Let (Rec fin_bounders) body_cpr, body_aval)
 223       where
 224       (rhs_rho, fin_bounders) = ntimes
 225                                 (length bounders)
 226                                 do_one_pass
 227                                 (init_rho, bounders)
 228
 229       (body_cpr, body_aval) = cprAnalExpr rhs_rho  body
 230
 231       init_rho = rho `extendVarEnvList` zip binders (repeat Bot)
 232       binders = map fst bounders
 233
 234
 235 cprAnalExpr rho (Case scrut bndr alts)
 236     = (Case scrut_cpr bndr alts_cpr, alts_aval)
 237       where
 238       (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
 239       (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
 240
 241 cprAnalExpr rho (Note n exp)
 242     = (Note n exp_cpr, note_aval)
 243       where
 244       (exp_cpr, note_aval) = cprAnalExpr rho exp
 245
 246 cprAnalExpr rho (Type t)
 247     = (Type t, Top)
 248
 249
 250 cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
 251 cprAnalCaseAlts rho alts
 252     = foldl anal_alt ([], Bot) alts
 253       where
 254       anal_alt :: ([CoreAlt], AbsVal) -> CoreAlt -> ([CoreAlt], AbsVal)
 255       anal_alt (done, aval) (con, binds, exp)
 256           = (done ++ [(con,binds,exp_cpr)], aval `lub` exp_aval)
 257             where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
 258                   rho' = rho `extendVarEnvList` (zip binds (repeat Top))
 259
 260
 261 -- Does one analysis pass through a list of mutually recursive bindings.
 262 do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)])
 263 do_one_pass  (i_rho,bounders)
 264     = foldl anal_bind (i_rho, []) bounders
 265        where
 266          anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b,
 267                                           done ++ [(b,e')])
 268               where (e', e_absval) = cprAnalExpr c_rho e
 269                     e_absval' = snd (pinCPR b e e_absval)
 270
 271
 272 -- take a binding pair and the abs val calculated from the rhs and
 273 -- calculate a new absval taking into account sufficient manifest
 274 -- lambda condition and that product arguments must be non-functional
 275 -- to have CPR property.
 276 -- Also we pin the var's CPR property to it.  This only has the CPR property if
 277 -- its a function
 278
 279 pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal)
 280 pinCPR v e av = case av of
 281                 Tuple _ ->
 282                     -- v is function with sufficent lambdas?
 283                     if v_is_fn then
 284                        if {- pprTrace "pinCPR:" (ppr v <+> text "type args:" <+>
 285                                               ppr argtys <+> text "lambda bound vars" <+>
 286                                               ppr val_binders) -} (length argtys == length val_binders) then
 287                           (addCpr av, av)
 288                        else (addCpr Top, Top)
 289                     else
 290                       -- not a function.
 291                       -- Pin NoInfo to v. If v appears in the interface file then an
 292                       -- importing module will check to see if it has an unfolding
 293                       -- with a constructor at its head.  If it does it will re-analyse
 294                       -- the folding.  I could do the check here, but I don't know if
 295                       -- the current unfolding info is final.
 296                       (addCpr Top,
 297                        -- OK, not a function but retain CPR info if it has a constructor
 298                        -- at its head, and thus will be inlined and simplified by
 299                        -- case of a known constructor
 300                        if isCon e then
 301                          -- Need to filter out functions from nested results
 302                          filterAbsTuple (av, v_type)
 303                        else Top)
 304                 _ -> (addCpr av, av)
 305     where
 306     -- func to pin CPR info on a var
 307     addCpr :: AbsVal -> Var
 308     addCpr = (setIdCprInfo v).absToCprInfo
 309     v_type = varType v
 310     -- Split argument types and result type from v's type
 311     (_, argtys, zz_result_type) = splitTypeToFunArgAndRes v_type
 312     v_is_fn = argtys /= []
 313     -- val_binders are the explicit lambdas at the head of the expression
 314     (binders,zz_stripped_exp) = collectBinders e
 315     val_binders = filter (not.isTyVar) binders
 316
 317 filterAbsTuple :: (AbsVal, Type) -> AbsVal
 318 filterAbsTuple (av@(Tuple args), ty)
 319   = case splitProductType_maybe ty of
 320       Nothing -> WARN( True, text "filterAbsTuple" <+> ppr ty)  -- Or should it be a panic?
 321                  Top
 322       Just (tycon, _, data_con, inst_con_arg_tys)
 323           |  isNewTyCon tycon
 324           -> ASSERT ( null $ tail inst_con_arg_tys )
 325              filterAbsTuple (av, head inst_con_arg_tys)
 326           |  otherwise
 327           -> Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys
 328
 329 filterAbsTuple (av, _) = av
 330
 331 absToCprInfo :: AbsVal -> CprInfo
 332 absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
 333 absToCprInfo _ = NoCPRInfo
 334
 335 cprInfoToAbs :: CprInfo -> AbsVal
 336 cprInfoToAbs NoCPRInfo = Top
 337 cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args
 338
 339 \end{code}
 340
 341 %************************************************************************
 342 %*                                                                      *
 343 \subsection{Utilities}
 344 %*                                                                      *
 345 %************************************************************************
 346
 347
 348 Now we define a couple of functions that split up types, they should
 349 be moved to Type.lhs if it is agreed that they are doing something
 350 that is sensible.
 351
 352 \begin{code}
 353
 354 -- Split a function type into forall tyvars, argument types and result type.
 355 -- If the type isn't a function type then tyvars and argument types will be
 356 -- empty lists.
 357
 358 -- Experimental,  look through new types.  I have given up on this for now,
 359 -- if the target of a function is a new type which is a function (see monadic
 360 -- functions for examples) we could look into these.  However,  it turns out that
 361 -- the (necessary) coercions in the code stop the beneficial simplifications.
 362 splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type)
 363 splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
 364     where (tyvars, funty) = splitForAllTys ty
 365           (argtys, resty) = splitFunTysIgnoringNewTypes funty
 366 --          (argtys, resty) = splitFunTys funty
 367
 368 -- Taken from splitFunTys in Type.lhs.  Modified to keep searching through newtypes
 369 -- Should move to Type.lhs if it is doing something sensible.
 370 splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
 371 splitFunTysIgnoringNewTypes ty = split ty
 372   where
 373     split ty = case splitNewType_maybe res of
 374                  Nothing     -> (args, res)
 375                  Just rep_ty -> (args ++ args', res')
 376                              where
 377                                 (args', res') = split rep_ty
 378              where
 379                 (args, res) = splitFunTys ty
 380
 381 -- Is this the constructor for a product type (i.e. algebraic, single constructor)
 382 isConProdType :: Con -> Bool
 383 isConProdType (DataCon con) = isProductTyCon tycon && not (isUnLiftedTyCon tycon)
 384                               where
 385                               tycon = dataConTyCon con
 386 isConProdType _ = False
 387
 388 -- returns True iff head of expression is a constructor
 389 -- Should I look through notes?
 390 isCon :: CoreExpr -> Bool
 391 isCon (Con c _) = isWHNFCon c  -- is this the right test?
 392 isCon _         = False
 393 \end{code}
 394
 395 \begin{code}
 396 -- Compose a function with itself n times.  This must be in a library
 397 -- somewhere,  but where!
 398 ntimes :: Int -> (a -> a) -> (a -> a)
 399 ntimes 0 f = id
 400 ntimes 1 f = f
 401 ntimes n f = f . ntimes (n-1) f
 402
 403 \end{code}