ghc/compiler/specialise/SpecConstr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[SpecConstr]{Specialise over constructors}
   5
   6 \begin{code}
   7 module SpecConstr(
   8         specConstrProgram
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreSyn
  14 import CoreLint         ( showPass, endPass )
  15 import CoreUtils        ( exprType, eqExpr )
  16 import CoreFVs          ( exprsFreeVars )
  17 import DataCon          ( dataConRepArity )
  18 import Type             ( tyConAppArgs )
  19 import PprCore          ( pprCoreRules, pprCoreRule )
  20 import Id               ( Id, idName, idType, idSpecialisation,
  21                           isDataConId_maybe,
  22                           mkUserLocal, mkSysLocal )
  23 import Var              ( Var )
  24 import VarEnv
  25 import VarSet
  26 import Name             ( nameOccName, nameSrcLoc )
  27 import Rules            ( addIdSpecialisations )
  28 import OccName          ( mkSpecOcc )
  29 import ErrUtils         ( dumpIfSet_dyn )
  30 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  31 import Outputable
  32
  33 import Maybes           ( orElse )
  34 import Util             ( mapAccumL )
  35 import List             ( nubBy, partition )
  36 import UniqSupply
  37 import Outputable
  38 import UniqFM           ( ufmToList )
  39 \end{code}
  40
  41 -----------------------------------------------------
  42                         Game plan
  43 -----------------------------------------------------
  44
  45 Consider
  46         drop n []     = []
  47         drop 0 xs     = []
  48         drop n (x:xs) = drop (n-1) xs
  49
  50 After the first time round, we could pass n unboxed.  This happens in
  51 numerical code too.  Here's what it looks like in Core:
  52
  53         drop n xs = case xs of
  54                       []     -> []
  55                       (y:ys) -> case n of
  56                                   I# n# -> case n# of
  57                                              0 -> []
  58                                              _ -> drop (I# (n# -# 1#)) xs
  59
  60 Notice that the recursive call has an explicit constructor as argument.
  61 Noticing this, we can make a specialised version of drop
  62
  63         RULE: drop (I# n#) xs ==> drop' n# xs
  64
  65         drop' n# xs = let n = I# n# in ...orig RHS...
  66
  67 Now the simplifier will apply the specialisation in the rhs of drop', giving
  68
  69         drop' n# xs = case xs of
  70                       []     -> []
  71                       (y:ys) -> case n# of
  72                                   0 -> []
  73                                   _ -> drop (n# -# 1#) xs
  74
  75 Much better!
  76
  77 We'd also like to catch cases where a parameter is carried along unchanged,
  78 but evaluated each time round the loop:
  79
  80         f i n = if i>0 || i>n then i else f (i*2) n
  81
  82 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
  83 In Core, by the time we've w/wd (f is strict in i) we get
  84
  85         f i# n = case i# ># 0 of
  86                    False -> I# i#
  87                    True  -> case n of n' { I# n# ->
  88                             case i# ># n# of
  89                                 False -> I# i#
  90                                 True  -> f (i# *# 2#) n'
  91
  92 At the call to f, we see that the argument, n is know to be (I# n#),
  93 and n is evaluated elsewhere in the body of f, so we can play the same
  94 trick as above.  However we don't want to do that if the boxed version
  95 of n is needed (else we'd avoid the eval but pay more for re-boxing n).
  96 So in this case we want that the *only* uses of n are in case statements.
  97
  98
  99 So we look for
 100
 101 * A self-recursive function.  Ignore mutual recursion for now,
 102   because it's less common, and the code is simpler for self-recursion.
 103
 104 * EITHER
 105
 106    a) At a recursive call, one or more parameters is an explicit
 107       constructor application
 108         AND
 109       That same parameter is scrutinised by a case somewhere in
 110       the RHS of the function
 111
 112   OR
 113
 114     b) At a recursive call, one or more parameters has an unfolding
 115        that is an explicit constructor application
 116         AND
 117       That same parameter is scrutinised by a case somewhere in
 118       the RHS of the function
 119         AND
 120       Those are the only uses of the parameter
 121
 122
 123 There's a bit of a complication with type arguments.  If the call
 124 site looks like
 125
 126         f p = ...f ((:) [a] x xs)...
 127
 128 then our specialised function look like
 129
 130         f_spec x xs = let p = (:) [a] x xs in ....as before....
 131
 132 This only makes sense if either
 133   a) the type variable 'a' is in scope at the top of f, or
 134   b) the type variable 'a' is an argument to f (and hence fs)
 135
 136 Actually, (a) may hold for value arguments too, in which case
 137 we may not want to pass them.  Supose 'x' is in scope at f's
 138 defn, but xs is not.  Then we'd like
 139
 140         f_spec xs = let p = (:) [a] x xs in ....as before....
 141
 142 Similarly (b) may hold too.  If x is already an argument at the
 143 call, no need to pass it again.
 144
 145 Finally, if 'a' is not in scope at the call site, we could abstract
 146 it as we do the term variables:
 147
 148         f_spec a x xs = let p = (:) [a] x xs in ...as before...
 149
 150 So the grand plan is:
 151
 152         * abstract the call site to a constructor-only pattern
 153           e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
 154
 155         * Find the free variables of the abstracted pattern
 156
 157         * Pass these variables, less any that are in scope at
 158           the fn defn.
 159
 160
 161 NOTICE that we only abstract over variables that are not in scope,
 162 so we're in no danger of shadowing variables used in "higher up"
 163 in f_spec's RHS.
 164
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \subsection{Top level wrapper stuff}
 169 %*                                                                      *
 170 %************************************************************************
 171
 172 \begin{code}
 173 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 174 specConstrProgram dflags us binds
 175   = do
 176         showPass dflags "SpecConstr"
 177
 178         let (binds', _) = initUs us (go emptyScEnv binds)
 179
 180         endPass dflags "SpecConstr" Opt_D_dump_spec binds'
 181
 182         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 183                   (vcat (map dump_specs (concat (map bindersOf binds'))))
 184
 185         return binds'
 186   where
 187     go env []           = returnUs []
 188     go env (bind:binds) = scBind env bind       `thenUs` \ (env', _, bind') ->
 189                           go env' binds         `thenUs` \ binds' ->
 190                           returnUs (bind' : binds')
 191
 192 dump_specs var = pprCoreRules var (idSpecialisation var)
 193 \end{code}
 194
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection{Environment: goes downwards}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 \begin{code}
 203 data ScEnv = SCE { scope :: VarEnv HowBound,
 204                         -- Binds all non-top-level variables in scope
 205
 206                    cons  :: ConstrEnv
 207              }
 208
 209 type ConstrEnv = IdEnv (AltCon, [CoreArg])
 210         -- Variables known to be bound to a constructor
 211         -- in a particular case alternative
 212
 213 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 214
 215 data HowBound = RecFun          -- These are the recursive functions for which
 216                                 -- we seek interesting call patterns
 217
 218               | RecArg          -- These are those functions' arguments; we are
 219                                 -- interested to see if those arguments are scrutinised
 220
 221               | Other           -- We track all others so we know what's in scope
 222                                 -- This is used in spec_one to check what needs to be
 223                                 -- passed as a parameter and what is in scope at the
 224                                 -- function definition site
 225
 226 instance Outputable HowBound where
 227   ppr RecFun = text "RecFun"
 228   ppr RecArg = text "RecArg"
 229   ppr Other = text "Other"
 230
 231 lookupScopeEnv env v = lookupVarEnv (scope env) v
 232
 233 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
 234 extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }
 235
 236     -- When we encounter
 237     --  case scrut of b
 238     --      C x y -> ...
 239     -- we want to bind b, and perhaps scrut too, to (C x y)
 240 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
 241 extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
 242   = extendBndrs env (case_bndr : alt_bndrs)
 243
 244 extendCaseBndrs env case_bndr scrut con alt_bndrs
 245   = case scrut of
 246         Var v ->   -- Bind the scrutinee in the ConstrEnv if it's a variable
 247                    -- Also forget if the scrutinee is a RecArg, because we're
 248                    -- now in the branch of a case, and we don't want to
 249                    -- record a non-scrutinee use of v if we have
 250                    --   case v of { (a,b) -> ...(f v)... }
 251                  SCE { scope = extendVarEnv (scope env1) v Other,
 252                        cons  = extendVarEnv (cons env1)  v (con,args) }
 253         other -> env1
 254
 255   where
 256     env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
 257                  cons  = extendVarEnv     (cons  env) case_bndr (con,args) }
 258
 259     args = map Type (tyConAppArgs (idType case_bndr)) ++
 260            map varToCoreExpr alt_bndrs
 261
 262     -- When we encounter a recursive function binding
 263     --  f = \x y -> ...
 264     -- we want to extend the scope env with bindings
 265     -- that record that f is a RecFn and x,y are RecArgs
 266 extendRecBndr env fn bndrs
 267   =  env { scope = scope env `extendVarEnvList`
 268                    ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
 269 \end{code}
 270
 271
 272 %************************************************************************
 273 %*                                                                      *
 274 \subsection{Usage information: flows upwards}
 275 %*                                                                      *
 276 %************************************************************************
 277
 278 \begin{code}
 279 data ScUsage
 280    = SCU {
 281         calls :: !(IdEnv ([Call])),     -- Calls
 282                                         -- The functions are a subset of the
 283                                         --      RecFuns in the ScEnv
 284
 285         occs :: !(IdEnv ArgOcc)         -- Information on argument occurrences
 286      }                                  -- The variables are a subset of the
 287                                         --      RecArg in the ScEnv
 288
 289 type Call = (ConstrEnv, [CoreArg])
 290         -- The arguments of the call, together with the
 291         -- env giving the constructor bindings at the call site
 292
 293 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
 294
 295 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
 296                            occs  = plusVarEnv_C combineOcc (occs u1) (occs u2) }
 297
 298 combineUsages [] = nullUsage
 299 combineUsages us = foldr1 combineUsage us
 300
 301 data ArgOcc = CaseScrut
 302             | OtherOcc
 303             | Both
 304
 305 instance Outputable ArgOcc where
 306   ppr CaseScrut = ptext SLIT("case-scrut")
 307   ppr OtherOcc  = ptext SLIT("other-occ")
 308   ppr Both      = ptext SLIT("case-scrut and other")
 309
 310 combineOcc CaseScrut CaseScrut = CaseScrut
 311 combineOcc OtherOcc  OtherOcc  = OtherOcc
 312 combineOcc _         _         = Both
 313 \end{code}
 314
 315
 316 %************************************************************************
 317 %*                                                                      *
 318 \subsection{The main recursive function}
 319 %*                                                                      *
 320 %************************************************************************
 321
 322 The main recursive function gathers up usage information, and
 323 creates specialised versions of functions.
 324
 325 \begin{code}
 326 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
 327         -- The unique supply is needed when we invent
 328         -- a new name for the specialised function and its args
 329
 330 scExpr env e@(Type t) = returnUs (nullUsage, e)
 331 scExpr env e@(Lit l)  = returnUs (nullUsage, e)
 332 scExpr env e@(Var v)  = returnUs (varUsage env v OtherOcc, e)
 333 scExpr env (Note n e) = scExpr env e    `thenUs` \ (usg,e') ->
 334                         returnUs (usg, Note n e')
 335 scExpr env (Lam b e)  = scExpr (extendBndr env b) e     `thenUs` \ (usg,e') ->
 336                         returnUs (usg, Lam b e')
 337
 338 scExpr env (Case scrut b alts)
 339   = sc_scrut scrut              `thenUs` \ (scrut_usg, scrut') ->
 340     mapAndUnzipUs sc_alt alts   `thenUs` \ (alts_usgs, alts') ->
 341     returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
 342               Case scrut' b alts')
 343   where
 344     sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
 345     sc_scrut e         = scExpr env e
 346
 347     sc_alt (con,bs,rhs) = scExpr env1 rhs       `thenUs` \ (usg,rhs') ->
 348                           returnUs (usg, (con,bs,rhs'))
 349                         where
 350                           env1 = extendCaseBndrs env b scrut con bs
 351
 352 scExpr env (Let bind body)
 353   = scBind env bind     `thenUs` \ (env', bind_usg, bind') ->
 354     scExpr env' body    `thenUs` \ (body_usg, body') ->
 355     returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
 356
 357 scExpr env e@(App _ _)
 358   = let
 359         (fn, args) = collectArgs e
 360     in
 361     mapAndUnzipUs (scExpr env) args     `thenUs` \ (usgs, args') ->
 362     let
 363         arg_usg = combineUsages usgs
 364         fn_usg  | Var f <- fn,
 365                   Just RecFun <- lookupScopeEnv env f
 366                 = SCU { calls = unitVarEnv f [(cons env, args)],
 367                         occs  = emptyVarEnv }
 368                 | otherwise
 369                 = nullUsage
 370     in
 371     returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args')
 372         -- Don't bother to look inside fn;
 373         -- it's almost always a variable
 374
 375 ----------------------
 376 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 377 scBind env (Rec [(fn,rhs)])
 378   | not (null val_bndrs)
 379   = scExpr env_fn_body body             `thenUs` \ (usg, body') ->
 380     let
 381         SCU { calls = calls, occs = occs } = usg
 382     in
 383     specialise env fn bndrs body usg    `thenUs` \ (rules, spec_prs) ->
 384     returnUs (extendBndr env fn,        -- For the body of the letrec, just
 385                                         -- extend the env with Other to record
 386                                         -- that it's in scope; no funny RecFun business
 387               SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
 388               Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
 389   where
 390     (bndrs,body) = collectBinders rhs
 391     val_bndrs    = filter isId bndrs
 392     env_fn_body  = extendRecBndr env fn bndrs
 393
 394 scBind env (Rec prs)
 395   = mapAndUnzipUs do_one prs    `thenUs` \ (usgs, prs') ->
 396     returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
 397   where
 398     do_one (bndr,rhs) = scExpr env rhs  `thenUs` \ (usg, rhs') ->
 399                         returnUs (usg, (bndr,rhs'))
 400
 401 scBind env (NonRec bndr rhs)
 402   = scExpr env rhs      `thenUs` \ (usg, rhs') ->
 403     returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
 404
 405 ----------------------
 406 varUsage env v use
 407   | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
 408                                                 occs = unitVarEnv v use }
 409   | otherwise                           = nullUsage
 410 \end{code}
 411
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsection{The specialiser}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{code}
 420 specialise :: ScEnv
 421            -> Id                        -- Functionn
 422            -> [CoreBndr] -> CoreExpr    -- Its RHS
 423            -> ScUsage                   -- Info on usage
 424            -> UniqSM ([CoreRule],       -- Rules
 425                       [(Id,CoreExpr)])  -- Bindings
 426
 427 specialise env fn bndrs body (SCU {calls=calls, occs=occs})
 428   = getUs               `thenUs` \ us ->
 429     let
 430         all_calls = lookupVarEnv calls fn `orElse` []
 431
 432         good_calls :: [[CoreArg]]
 433         good_calls = [ pats
 434                      | (con_env, call_args) <- all_calls,
 435                        length call_args >= n_bndrs,         -- App is saturated
 436                        let call = (bndrs `zip` call_args),
 437                        any (good_arg con_env occs) call,    -- At least one arg is a constr app
 438                        let (_, pats) = argsToPats con_env us call_args
 439                      ]
 440     in
 441     mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
 442                   (nubBy same_call good_calls `zip` [1..])
 443   where
 444     n_bndrs  = length bndrs
 445     same_call as1 as2 = and (zipWith eqExpr as1 as2)
 446
 447 ---------------------
 448 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
 449 good_arg con_env arg_occs (bndr, arg)
 450   = case is_con_app_maybe con_env arg of
 451         Just _ ->  bndr_usg_ok arg_occs bndr arg
 452         other   -> False
 453
 454 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
 455 bndr_usg_ok arg_occs bndr arg
 456   = case lookupVarEnv arg_occs bndr of
 457         Just CaseScrut -> True                  -- Used only by case scrutiny
 458         Just Both      -> case arg of           -- Used by case and elsewhere
 459                             App _ _ -> True     -- so the arg should be an explicit con app
 460                             other   -> False
 461         other -> False                          -- Not used, or used wonkily
 462
 463
 464 ---------------------
 465 spec_one :: ScEnv
 466          -> Id                                  -- Function
 467          -> CoreExpr                            -- Rhs of the original function
 468          -> ([CoreArg], Int)
 469          -> UniqSM (CoreRule, (Id,CoreExpr))    -- Rule and binding
 470
 471 -- spec_one creates a specialised copy of the function, together
 472 -- with a rule for using it.  I'm very proud of how short this
 473 -- function is, considering what it does :-).
 474
 475 {-
 476   Example
 477
 478      In-scope: a, x::a
 479      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
 480           [c::*, v::(b,c) are presumably bound by the (...) part]
 481   ==>
 482      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
 483                   (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
 484
 485      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
 486                    v::(b,c),
 487                    hw::[(a,(b,c))] .
 488
 489             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 490 -}
 491
 492 spec_one env fn rhs (pats, n)
 493   = getUniqueUs                         `thenUs` \ spec_uniq ->
 494     let
 495         fn_name      = idName fn
 496         fn_loc       = nameSrcLoc fn_name
 497         spec_occ     = mkSpecOcc (nameOccName fn_name)
 498         pat_fvs      = varSetElems (exprsFreeVars pats)
 499         vars_to_bind = filter not_avail pat_fvs
 500         not_avail v  = not (v `elemVarEnv` scope env)
 501                 -- Put the type variables first; the type of a term
 502                 -- variable may mention a type variable
 503         (tvs, ids)   = partition isTyVar vars_to_bind
 504         bndrs        = tvs ++ ids
 505
 506         rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n))
 507         spec_rhs  = mkLams bndrs (mkApps rhs pats)
 508         spec_id   = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc
 509         rule      = Rule rule_name bndrs pats (mkVarApps (Var spec_id) bndrs)
 510     in
 511     returnUs (rule, (spec_id, spec_rhs))
 512 \end{code}
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection{Argument analysis}
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 This code deals with analysing call-site arguments to see whether
 521 they are constructor applications.
 522
 523 \begin{code}
 524     -- argToPat takes an actual argument, and returns an abstracted
 525     -- version, consisting of just the "constructor skeleton" of the
 526     -- argument, with non-constructor sub-expression replaced by new
 527     -- placeholder variables.  For example:
 528     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
 529
 530 argToPat   :: ConstrEnv -> UniqSupply -> CoreArg   -> (UniqSupply, CoreExpr)
 531 argToPat env us (Type ty)
 532   = (us, Type ty)
 533
 534 argToPat env us arg
 535   | Just (dc,args) <- is_con_app_maybe env arg
 536   = let
 537         (us',args') = argsToPats env us args
 538     in
 539     (us', mk_con_app dc args')
 540
 541 argToPat env us (Var v) -- Don't uniqify existing vars,
 542   = (us, Var v)         -- so that we can spot when we pass them twice
 543
 544 argToPat env us arg
 545   = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg)))
 546   where
 547     (us1,us2) = splitUniqSupply us
 548
 549 argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
 550 argsToPats env us args = mapAccumL (argToPat env) us args
 551 \end{code}
 552
 553
 554 \begin{code}
 555 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe (AltCon, [CoreExpr])
 556 is_con_app_maybe env (Var v)
 557   = lookupVarEnv env v
 558         -- You might think we could look in the idUnfolding here
 559         -- but that doesn't take account of which branch of a
 560         -- case we are in, which is the whole point
 561
 562 is_con_app_maybe env (Lit lit)
 563   = Just (LitAlt lit, [])
 564
 565 is_con_app_maybe env expr
 566   = case collectArgs expr of
 567         (Var fun, args) | Just con <- isDataConId_maybe fun,
 568                           length args >= dataConRepArity con
 569                 -- Might be > because the arity excludes type args
 570                         -> Just (DataAlt con,args)
 571
 572         other -> Nothing
 573
 574 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 575 mk_con_app (LitAlt lit)  []   = Lit lit
 576 mk_con_app (DataAlt con) args = mkConApp con args
 577 \end{code}