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 isConProdType con
 225          then Tuple args_aval_filt_funs
 226          else Top)
 227     where
 228       anal_con_args = map (cprAnalExpr rho) args
 229       args_cpr      = map fst anal_con_args
 230
 231       args_aval_filt_funs = if (not.isDataCon) con then
 232                                map snd anal_con_args
 233                             else
 234                                map (ifApply isFun (const Top)) $
 235                                 map snd $
 236                                 filter (not.isTypeArg.fst) anal_con_args
 237
 238 -- For apps we don't care about the argument's abs val.  This
 239 -- app will return a constructed product if the function does. We strip
 240 -- a Fun from the functions abs val, unless the argument is a type argument
 241 -- or it is already Top or Bot.
 242 cprAnalExpr rho (App fun arg@(Type _))
 243     = (App fun_cpr arg, fun_res)
 244       where
 245       (fun_cpr, fun_res)  = cprAnalExpr rho fun
 246
 247 cprAnalExpr rho (App fun arg)
 248     = (App fun_cpr arg_cpr, if fun_res==Top || fun_res==Bot
 249                             then fun_res
 250                             else res_res)
 251       where
 252       (fun_cpr, fun_res)  = cprAnalExpr rho fun
 253       (arg_cpr, _)        = cprAnalExpr rho arg
 254       Fun res_res         = fun_res
 255
 256 -- Map arguments to Top (we aren't constructing them)
 257 -- Return the abstract value of the body, since functions
 258 -- are represented by the CPR value of their result, and
 259 -- add a Fun for this lambda..
 260 cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
 261                              | otherwise = (Lam b body_cpr, Fun body_aval)
 262       where
 263       (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
 264
 265 cprAnalExpr rho (Let (NonRec binder rhs) body)
 266     = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval)
 267       where
 268       (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs
 269       (binder', rhs_aval') = pinCPR binder rhs_cpr rhs_aval
 270       (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval') body
 271
 272 cprAnalExpr rho (Let (Rec bounders) body)
 273     = (Let (Rec fin_bounders) body_cpr, body_aval)
 274       where
 275       (rhs_rho, fin_bounders) = nTimes
 276                                 (length bounders)
 277                                 do_one_pass
 278                                 (init_rho, bounders)
 279
 280       (body_cpr, body_aval) = cprAnalExpr rhs_rho  body
 281
 282       init_rho = rho `extendVarEnvList` zip binders (repeat Bot)
 283       binders = map fst bounders
 284
 285
 286 cprAnalExpr rho (Case scrut bndr alts)
 287     = (Case scrut_cpr bndr alts_cpr, alts_aval)
 288       where
 289       (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
 290       (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
 291
 292 cprAnalExpr rho (Note n exp)
 293     = (Note n exp_cpr, expr_aval)
 294       where
 295       (exp_cpr, expr_aval) = cprAnalExpr rho exp
 296
 297 cprAnalExpr rho (Type t)
 298     = (Type t, Top)
 299
 300
 301 cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
 302 cprAnalCaseAlts rho alts
 303     = foldl anal_alt ([], Bot) alts
 304       where
 305       anal_alt :: ([CoreAlt], AbsVal) -> CoreAlt -> ([CoreAlt], AbsVal)
 306       anal_alt (done, aval) (con, binds, exp)
 307           = (done ++ [(con,binds,exp_cpr)], aval `lub` exp_aval)
 308             where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
 309                   rho' = rho `extendVarEnvList` (zip binds (repeat Top))
 310
 311
 312 -- Does one analysis pass through a list of mutually recursive bindings.
 313 do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)])
 314 do_one_pass  (i_rho,bounders)
 315     = foldl anal_bind (i_rho, []) bounders
 316        where
 317          anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b,
 318                                           done ++ [(b,e')])
 319               where (e', e_absval) = cprAnalExpr c_rho e
 320                     e_absval' = snd (pinCPR b e e_absval)
 321
 322
 323 -- take a binding pair and the abs val calculated from the rhs and
 324 -- calculate a new absval taking into account sufficient manifest
 325 -- lambda condition
 326 -- Also we pin the var's CPR property to it.  A var only has the CPR property if
 327 -- it is a function
 328
 329 pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal)
 330 pinCPR v e av = case av of
 331                     -- is v a function with insufficent lambdas?
 332                  Fun _ | length argtys /= length val_binders ->
 333                       -- argtys must be greater than val_binders.  So stripped_exp
 334                       -- has a function type.  The head of this expr can't be lambda
 335                       -- a note, because we stripped them off before.  It can't be a
 336                       -- Con because it has a function type.  It can't be a Type.
 337                       -- If its an app, let or case then there is work to get the
 338                       -- and we can't do anything because we may lose laziness. *But*
 339                       -- if its a var (i.e. a function name) then we are fine.  Note
 340                       -- that I don't think this case is at all interesting,  but I have
 341                       -- a test program that generates it.
 342
 343                       -- UPDATE: 20 Jul 1999
 344                       -- I've decided not to allow this (useless) optimisation.  It will make
 345                       -- the w/w split more complex.
 346                       -- if isVar stripped_exp then
 347                       --    (addCpr av, av)
 348                       -- else
 349                             (addCpr Top, Top)
 350                  Tuple _ ->
 351                       -- not a function.
 352                       -- Pin NoInfo to v. If v appears in the interface file then an
 353                       -- importing module will check to see if it has an unfolding
 354                       -- with a constructor at its head (WHNF).  If it does it will re-analyse
 355                       -- the folding.  I could do the check here, but I don't know if
 356                       -- the current unfolding info is final.
 357                       (addCpr Top,
 358                        -- Retain CPR info if it has a constructor
 359                        -- at its head, and thus will be inlined and simplified by
 360                        -- case of a known constructor
 361                        if isCon e then av else Top)
 362                  _ -> (addCpr av, av)
 363     where
 364     -- func to pin CPR info on a var
 365     addCpr :: AbsVal -> Var
 366     addCpr = (setIdCprInfo v).absToCprInfo
 367
 368     -- Split argument types and result type from v's type
 369     (_, argtys, _) = (splitTypeToFunArgAndRes.varType) v
 370
 371     -- val_binders are the explicit lambdas at the head of the expression
 372     (_, val_binders, _) = collectTyAndValBinders e -- collectBindersIgnoringNotes e'
 373
 374
 375 absToCprInfo :: AbsVal -> CprInfo
 376 absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
 377 absToCprInfo (Fun r)      = absToCprInfo r
 378 absToCprInfo _            = NoCPRInfo
 379
 380 -- Cpr Info doesn't store the number of arguments a function has,  so the caller
 381 -- must take care to add the appropriate number of Funs.
 382 cprInfoToAbs :: CprInfo -> AbsVal
 383 cprInfoToAbs NoCPRInfo = Top
 384 cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args
 385
 386 \end{code}
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsection{Utilities}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394
 395 Now we define a couple of functions that split up types, they should
 396 be moved to Type.lhs if it is agreed that they are doing something
 397 that is sensible.
 398
 399 \begin{code}
 400
 401 -- Split a function type into forall tyvars, argument types and result type.
 402 -- If the type isn't a function type then tyvars and argument types will be
 403 -- empty lists.
 404
 405 -- Experimental,  look through new types.  I have given up on this for now,
 406 -- if the target of a function is a new type which is a function (see monadic
 407 -- functions for examples) we could look into these.  However,  it turns out that
 408 -- the (necessary) coercions in the code stop the beneficial simplifications.
 409 splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type)
 410 splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
 411     where (tyvars, funty) = splitForAllTys ty
 412           (argtys, resty) = splitFunTysIgnoringNewTypes funty
 413 --          (argtys, resty) = splitFunTys funty
 414
 415 -- splitFunTys, modified to keep searching through newtypes.
 416 -- Should move to Type.lhs if it is doing something sensible.
 417
 418 splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
 419 splitFunTysIgnoringNewTypes ty = split ty
 420   where
 421     split ty = case splitNewType_maybe res of
 422                  Nothing     -> (args, res)
 423                  Just rep_ty -> (args ++ args', res')
 424                              where
 425                                 (args', res') = split rep_ty
 426              where
 427                 (args, res) = splitFunTys ty
 428
 429
 430 -- Is this the constructor for a product type (i.e. algebraic, single constructor)
 431 -- NB: isProductTyCon replies 'False' for unboxed tuples
 432 isConProdType :: Con -> Bool
 433 isConProdType (DataCon con) = isProductTyCon . dataConTyCon $ con
 434 isConProdType _ = False
 435
 436 -- returns True iff head of expression is a constructor
 437 -- Should I look through notes? I think so ...
 438 isCon :: CoreExpr -> Bool
 439 isCon (Con c _) = isWHNFCon c  -- is this the right test?
 440 isCon (Note _n e) = isCon e
 441 isCon _         = False
 442
 443 -- Compose a function with itself n times.  (nth rather than twice)
 444 -- This must/should be in a library somewhere,  but where!
 445 nTimes :: Int -> (a -> a) -> (a -> a)
 446 nTimes 0 _ = id
 447 nTimes 1 f = f
 448 nTimes n f = f . nTimes (n-1) f
 449
 450 -- Only apply f to argument if it satisfies p
 451 ifApply :: (a -> Bool) -> (a -> a) -> (a -> a)
 452 ifApply p f x = if p x then f x else x
 453
 454 \end{code}