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