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, getIdArity,
  16                           isBottomingId )
  17 import IdInfo           ( CprInfo(..), arityLowerBound )
  18 import VarEnv
  19 import Type             ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys, splitNewType_maybe )
  20 import TyCon            ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
  21 import DataCon          ( dataConTyCon, splitProductType_maybe, dataConRawArgTys )
  22 import Const            ( Con(DataCon), isDataCon, isWHNFCon )
  23 import Util             ( zipEqual, zipWithEqual )
  24 import Outputable
  25
  26 import UniqFM (ufmToList)
  27 import Maybe
  28 import PprType( pprType )       -- Only called in debug messages
  29 \end{code}
  30
  31 This module performs an analysis of a set of Core Bindings for the
  32 Constructed Product Result (CPR) transformation.
  33
  34 It detects functions that always explicitly (manifestly?) construct a
  35 result value with a product type.  A product type is a type which has
  36 only one constructor. For example, tuples and boxed primitive values
  37 have product type.
  38
  39 We must also ensure that the function's body starts with sufficient
  40 manifest lambdas otherwise loss of sharing can occur.  See the comment
  41 in @StrictAnal.lhs@.
  42
  43 The transformation of bindings to worker/wrapper pairs is done by the
  44 worker-wrapper pass.  The worker-wrapper pass splits bindings on the
  45 basis of both strictness and CPR info.  If an id has both then it can
  46 combine the transformations so that only one pair is produced.
  47
  48 The analysis here detects nested CPR information.  For example, if a
  49 function returns a constructed pair, the first element of which is a
  50 constructed int, then the analysis will detect nested CPR information
  51 for the int as well.  Unfortunately, the current transformations can't
  52 take advantage of the nested CPR information.  They have (broken now,
  53 I think) code which will flatten out nested CPR components and rebuild
  54 them in the wrapper, but enabling this would lose laziness.  It is
  55 possible to make use of the nested info: if we knew that a caller was
  56 strict in that position then we could create a specialized version of
  57 the function which flattened/reconstructed that position.
  58
  59 It is not known whether this optimisation would be worthwhile.
  60
  61 So we generate and carry round nested CPR information, but before
  62 using this info to guide the creation of workers and wrappers we map
  63 all components of a CPRInfo to NoCprInfo.
  64
  65
  66 Data types
  67 ~~~~~~~~~~
  68
  69 Within this module Id's CPR information is represented by
  70 ``AbsVal''. When adding this information to the Id's pragma info field
  71 we convert the ``Absval'' to a ``CprInfo'' value.
  72
  73 Abstract domains consist of a `no information' value (Top), a function
  74 value (Fun) which when applied to an argument returns a new AbsVal
  75 (note the argument is not used in any way), , for product types, a
  76 corresponding length tuple (Tuple) of abstract values.  And finally,
  77 Bot.  Bot is not a proper abstract value but a generic bottom is
  78 useful for calculating fixpoints and representing divergent
  79 computations.  Note that we equate Bot and Fun^n Bot (n > 0), and
  80 likewise for Top.  This saves a lot of delving in types to keep
  81 everything exactly correct.
  82
  83 Since functions abstract to constant functions we could just
  84 represent them by the abstract value of their result.  However,  it
  85 turns out (I know - I tried!) that this requires a lot of type
  86 manipulation and the code is more straightforward if we represent
  87 functions by an abstract constant function.
  88
  89 \begin{code}
  90 data AbsVal = Top                -- Not a constructed product
  91             | Fun AbsVal         -- A function that takes an argument
  92                                  -- and gives AbsVal as result.
  93             | Tuple [AbsVal]     -- A constructed product of values
  94             | Bot                -- Bot'tom included for convenience
  95                                  -- we could use appropriate Tuple Vals
  96      deriving (Eq,Show)
  97
  98 isFun :: AbsVal -> Bool
  99 isFun (Fun _) = True
 100 isFun _       = False
 101
 102 -- For pretty debugging
 103 instance Outputable AbsVal where
 104   ppr Top                       = ptext SLIT("Top")
 105   ppr (Fun r)                   = ptext SLIT("Fun->") <> (parens.ppr) r
 106   ppr (Tuple la)                = ptext SLIT("Tuple ") <> text "[" <>
 107                                   (hsep (punctuate comma (map ppr la))) <>
 108                                   text "]"
 109   ppr Bot                       = ptext SLIT("Bot")
 110
 111
 112 -- lub takes the lowest upper bound of two abstract values, standard.
 113 lub :: AbsVal -> AbsVal -> AbsVal
 114 lub Bot a = a
 115 lub a Bot = a
 116 lub Top a = Top
 117 lub a Top = Top
 118 lub (Tuple l) (Tuple r) = Tuple (zipWithEqual "CPR: lub" lub l r)
 119 lub (Fun l) (Fun r)     = Fun (lub l r)
 120 lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple"
 121
 122
 123 \end{code}
 124
 125 The environment maps Ids to their abstract CPR value.
 126
 127 \begin{code}
 128
 129 type CPREnv = VarEnv AbsVal
 130
 131 initCPREnv = emptyVarEnv
 132
 133 \end{code}
 134
 135 Programs
 136 ~~~~~~~~
 137
 138 Take a list of core bindings and return a new list with CPR function
 139 ids decorated with their CprInfo pragmas.
 140
 141 \begin{code}
 142
 143 cprAnalyse :: [CoreBind]
 144                  -> IO [CoreBind]
 145 cprAnalyse binds
 146   = do {
 147         beginPass "Constructed Product analysis" ;
 148         let { binds_plus_cpr = do_prog binds } ;
 149         endPass "Constructed Product analysis"
 150                 (opt_D_dump_cpranal || opt_D_verbose_core2core)
 151                 binds_plus_cpr
 152     }
 153   where
 154     do_prog :: [CoreBind] -> [CoreBind]
 155     do_prog binds
 156         = snd $ foldl analBind (initCPREnv, []) binds
 157         where
 158         analBind :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind])
 159         analBind (rho,done_binds) bind
 160             = (extendVarEnvList rho env, done_binds ++ [bind'])
 161               where
 162               (env, bind') = cprAnalTopBind rho bind
 163
 164 \end{code}
 165
 166 The cprAnal functions take binds/expressions and an environment which
 167 gives CPR info for visible ids and returns a new bind/expression
 168 with ids decorated with their CPR info.
 169
 170 \begin{code}
 171 -- Return environment updated with info from this binding
 172 cprAnalTopBind :: CPREnv -> CoreBind -> ([(Var, AbsVal)], CoreBind)
 173 cprAnalTopBind rho (NonRec v e)
 174     = ([(v', e_absval')], NonRec v' e_pluscpr)
 175       where
 176       (e_pluscpr, e_absval) = cprAnalExpr rho e
 177       (v', e_absval')       = pinCPR v e e_absval
 178
 179 -- When analyzing mutually recursive bindings the iterations to find
 180 -- a fixpoint is bounded by the number of bindings in the group.
 181 -- for simplicity we just iterate that number of times.
 182 cprAnalTopBind rho (Rec bounders)
 183     = (map (\(b,e) -> (b, lookupVarEnv_NF fin_rho b)) fin_bounders',
 184        Rec fin_bounders')
 185       where
 186       init_rho = rho `extendVarEnvList`  (zip binders (repeat Bot))
 187       binders = map fst bounders
 188
 189       (fin_rho, fin_bounders) = nTimes (length bounders)
 190                                        do_one_pass
 191                                        (init_rho, bounders)
 192       fin_bounders' = map (\(b,e) -> (fst $ pinCPR b e (lookupVarEnv_NF fin_rho b), e))
 193                       fin_bounders
 194
 195 cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
 196
 197
 198 -- If Id will always diverge when given sufficient arguments then
 199 -- we can just set its abs val to Bot.  Any other CPR info
 200 -- from other paths will then dominate,  which is what we want.
 201 -- Check in rho,  if not there it must be imported, so check
 202 -- the var's idinfo.
 203 cprAnalExpr rho e@(Var v)
 204     | isBottomingId v = (e, Bot)
 205     | otherwise       = (e, case lookupVarEnv rho v of
 206                              Just a_val -> a_val
 207                              Nothing    -> cpr_prag_a_val)
 208     where
 209     ids_inf   = (cprInfoToAbs.getIdCprInfo) v
 210     ids_arity = (arityLowerBound.getIdArity) v
 211     cpr_prag_a_val = case ids_inf of
 212                        Top -> -- if we can inline this var, and its a constructor app
 213                               -- then analyse the unfolding
 214                               case (maybeUnfoldingTemplate.getIdUnfolding) v of
 215                                 Just e | isCon e ->  snd $ cprAnalExpr rho e
 216                                 zz_other         -> Top
 217                        zz_other -> -- Unfortunately,  cprinfo doesn't store the # of args
 218                                    nTimes ids_arity Fun ids_inf
 219
 220 -- Return constructor with decorated arguments.  If constructor
 221 -- has product type then this is a manifest constructor (hooray!)
 222 cprAnalExpr rho (Con con args)
 223     = (Con con args_cpr,
 224        -- If we are a product with 0 args we must be void(like)
 225        -- We can't create an unboxed tuple with 0 args for this
 226        -- and since Void has only one, constant value it should
 227        -- just mean returning a pointer to a pre-existing cell.
 228        -- So we won't really gain from doing anything fancy
 229        -- and we treat this case as Top.
 230        if    isConProdType con
 231           && length args > 0
 232          then Tuple args_aval_filt_funs
 233          else Top)
 234     where
 235       anal_con_args = map (cprAnalExpr rho) args
 236       args_cpr      = map fst anal_con_args
 237
 238       args_aval_filt_funs = if (not.isDataCon) con then
 239                                map snd anal_con_args
 240                             else
 241                                map (ifApply isFun (const Top)) $
 242                                 map snd $
 243                                 filter (not.isTypeArg.fst) anal_con_args
 244
 245 -- For apps we don't care about the argument's abs val.  This
 246 -- app will return a constructed product if the function does. We strip
 247 -- a Fun from the functions abs val, unless the argument is a type argument
 248 -- or it is already Top or Bot.
 249 cprAnalExpr rho (App fun arg@(Type _))
 250     = (App fun_cpr arg, fun_res)
 251       where
 252       (fun_cpr, fun_res)  = cprAnalExpr rho fun
 253
 254 cprAnalExpr rho (App fun arg)
 255     = (App fun_cpr arg_cpr, if fun_res==Top || fun_res==Bot
 256                             then fun_res
 257                             else res_res)
 258       where
 259       (fun_cpr, fun_res)  = cprAnalExpr rho fun
 260       (arg_cpr, _)        = cprAnalExpr rho arg
 261       Fun res_res         = fun_res
 262
 263 -- Map arguments to Top (we aren't constructing them)
 264 -- Return the abstract value of the body, since functions
 265 -- are represented by the CPR value of their result, and
 266 -- add a Fun for this lambda..
 267 cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
 268                              | otherwise = (Lam b body_cpr, Fun body_aval)
 269       where
 270       (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
 271
 272 cprAnalExpr rho (Let (NonRec binder rhs) body)
 273     = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval)
 274       where
 275       (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs
 276       (binder', rhs_aval') = pinCPR binder rhs_cpr rhs_aval
 277       (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval') body
 278
 279 cprAnalExpr rho (Let (Rec bounders) body)
 280     = (Let (Rec fin_bounders) body_cpr, body_aval)
 281       where
 282       (rhs_rho, fin_bounders) = nTimes
 283                                 (length bounders)
 284                                 do_one_pass
 285                                 (init_rho, bounders)
 286
 287       (body_cpr, body_aval) = cprAnalExpr rhs_rho  body
 288
 289       init_rho = rho `extendVarEnvList` zip binders (repeat Bot)
 290       binders = map fst bounders
 291
 292
 293 cprAnalExpr rho (Case scrut bndr alts)
 294     = (Case scrut_cpr bndr alts_cpr, alts_aval)
 295       where
 296       (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
 297       (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
 298
 299 cprAnalExpr rho (Note n exp)
 300     = (Note n exp_cpr, expr_aval)
 301       where
 302       (exp_cpr, expr_aval) = cprAnalExpr rho exp
 303
 304 cprAnalExpr rho (Type t)
 305     = (Type t, Top)
 306
 307
 308 cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
 309 cprAnalCaseAlts rho alts
 310     = foldl anal_alt ([], Bot) alts
 311       where
 312       anal_alt :: ([CoreAlt], AbsVal) -> CoreAlt -> ([CoreAlt], AbsVal)
 313       anal_alt (done, aval) (con, binds, exp)
 314           = (done ++ [(con,binds,exp_cpr)], aval `lub` exp_aval)
 315             where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
 316                   rho' = rho `extendVarEnvList` (zip binds (repeat Top))
 317
 318
 319 -- Does one analysis pass through a list of mutually recursive bindings.
 320 do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)])
 321 do_one_pass  (i_rho,bounders)
 322     = foldl anal_bind (i_rho, []) bounders
 323        where
 324          anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b,
 325                                           done ++ [(b,e')])
 326               where (e', e_absval) = cprAnalExpr c_rho e
 327                     e_absval' = snd (pinCPR b e e_absval)
 328
 329
 330 -- take a binding pair and the abs val calculated from the rhs and
 331 -- calculate a new absval taking into account sufficient manifest
 332 -- lambda condition
 333 -- Also we pin the var's CPR property to it.  A var only has the CPR property if
 334 -- it is a function
 335
 336 pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal)
 337 pinCPR v e av = case av of
 338                     -- is v a function with insufficent lambdas?
 339                  Fun _ | length argtys /= length val_binders ->
 340                       -- argtys must be greater than val_binders.  So stripped_exp
 341                       -- has a function type.  The head of this expr can't be lambda
 342                       -- a note, because we stripped them off before.  It can't be a
 343                       -- Con because it has a function type.  It can't be a Type.
 344                       -- If its an app, let or case then there is work to get the
 345                       -- and we can't do anything because we may lose laziness. *But*
 346                       -- if its a var (i.e. a function name) then we are fine.  Note
 347                       -- that I don't think this case is at all interesting,  but I have
 348                       -- a test program that generates it.
 349
 350                       -- UPDATE: 20 Jul 1999
 351                       -- I've decided not to allow this (useless) optimisation.  It will make
 352                       -- the w/w split more complex.
 353                       -- if isVar stripped_exp then
 354                       --    (addCpr av, av)
 355                       -- else
 356                             (addCpr Top, Top)
 357                  Tuple _ ->
 358                       -- not a function.
 359                       -- Pin NoInfo to v. If v appears in the interface file then an
 360                       -- importing module will check to see if it has an unfolding
 361                       -- with a constructor at its head (WHNF).  If it does it will re-analyse
 362                       -- the folding.  I could do the check here, but I don't know if
 363                       -- the current unfolding info is final.
 364                       (addCpr Top,
 365                        -- Retain CPR info if it has a constructor
 366                        -- at its head, and thus will be inlined and simplified by
 367                        -- case of a known constructor
 368                        if isCon e then av else Top)
 369                  _ -> (addCpr av, av)
 370     where
 371     -- func to pin CPR info on a var
 372     addCpr :: AbsVal -> Var
 373     addCpr = (setIdCprInfo v).absToCprInfo
 374
 375     -- Split argument types and result type from v's type
 376     (_, argtys, _) = (splitTypeToFunArgAndRes.varType) v
 377
 378     -- val_binders are the explicit lambdas at the head of the expression
 379     (_, val_binders, _) = collectTyAndValBinders e -- collectBindersIgnoringNotes e'
 380
 381
 382 absToCprInfo :: AbsVal -> CprInfo
 383 absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
 384 absToCprInfo (Fun r)      = absToCprInfo r
 385 absToCprInfo _            = NoCPRInfo
 386
 387 -- Cpr Info doesn't store the number of arguments a function has,  so the caller
 388 -- must take care to add the appropriate number of Funs.
 389 cprInfoToAbs :: CprInfo -> AbsVal
 390 cprInfoToAbs NoCPRInfo = Top
 391 cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args
 392
 393 \end{code}
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection{Utilities}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401
 402 Now we define a couple of functions that split up types, they should
 403 be moved to Type.lhs if it is agreed that they are doing something
 404 that is sensible.
 405
 406 \begin{code}
 407
 408 -- Split a function type into forall tyvars, argument types and result type.
 409 -- If the type isn't a function type then tyvars and argument types will be
 410 -- empty lists.
 411
 412 -- Experimental,  look through new types.  I have given up on this for now,
 413 -- if the target of a function is a new type which is a function (see monadic
 414 -- functions for examples) we could look into these.  However,  it turns out that
 415 -- the (necessary) coercions in the code stop the beneficial simplifications.
 416 splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type)
 417 splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
 418     where (tyvars, funty) = splitForAllTys ty
 419           (argtys, resty) = splitFunTysIgnoringNewTypes funty
 420 --          (argtys, resty) = splitFunTys funty
 421
 422 -- splitFunTys, modified to keep searching through newtypes.
 423 -- Should move to Type.lhs if it is doing something sensible.
 424
 425 splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
 426 splitFunTysIgnoringNewTypes ty = split ty
 427   where
 428     split ty = case splitNewType_maybe res of
 429                  Nothing     -> (args, res)
 430                  Just rep_ty -> (args ++ args', res')
 431                              where
 432                                 (args', res') = split rep_ty
 433              where
 434                 (args, res) = splitFunTys ty
 435
 436
 437 -- Is this the constructor for a product type (i.e. algebraic, single constructor)
 438 -- NB: isProductTyCon replies 'False' for unboxed tuples
 439 isConProdType :: Con -> Bool
 440 isConProdType (DataCon con) = isProductTyCon . dataConTyCon $ con
 441 isConProdType _ = False
 442
 443 -- returns True iff head of expression is a constructor
 444 -- Should I look through notes? I think so ...
 445 isCon :: CoreExpr -> Bool
 446 isCon (Con c _) = isWHNFCon c  -- is this the right test?
 447 isCon (Note _ e) = isCon e
 448 isCon _         = False
 449
 450 -- Compose a function with itself n times.  (nth rather than twice)
 451 -- This must/should be in a library somewhere,  but where!
 452 nTimes :: Int -> (a -> a) -> (a -> a)
 453 nTimes 0 _ = id
 454 nTimes 1 f = f
 455 nTimes n f = f . nTimes (n-1) f
 456
 457 -- Only apply f to argument if it satisfies p
 458 ifApply :: (a -> Bool) -> (a -> a) -> (a -> a)
 459 ifApply p f x = if p x then f x else x
 460
 461 \end{code}