ghc/compiler/specialise/Rules.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreRules]{Transformation rules}
   5
   6 \begin{code}
   7 module Rules (
   8         RuleBase, prepareRuleBase, lookupRule,
   9         addIdSpecialisations,
  10         ProtoCoreRule(..), pprProtoCoreRule,
  11         orphanRule
  12     ) where
  13
  14 #include "HsVersions.h"
  15
  16 import CoreSyn          -- All of it
  17 import OccurAnal        ( occurAnalyseExpr, tagBinders, UsageDetails )
  18 import BinderInfo       ( markMany )
  19 import CoreFVs          ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
  20 import CoreUnfold       ( Unfolding(..) )
  21 import CoreUtils        ( whnfOrBottom, eqExpr )
  22 import PprCore          ( pprCoreRule )
  23 import Subst            ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
  24                           mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
  25                           unBindSubst, bindSubstList, unBindSubstList,
  26                         )
  27 import Id               ( Id, getIdUnfolding,
  28                           getIdSpecialisation, setIdSpecialisation,
  29                           setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
  30                         )
  31 import IdInfo           ( zapLamIdInfo, setSpecInfo, specInfo )
  32 import Name             ( Name, isLocallyDefined )
  33 import Var              ( isTyVar, isId )
  34 import VarSet
  35 import VarEnv
  36 import Type             ( mkTyVarTy, getTyVar_maybe )
  37 import qualified Unify  ( match )
  38 import CmdLineOpts      ( opt_D_dump_simpl, opt_D_verbose_core2core )
  39
  40 import UniqFM
  41 import ErrUtils         ( dumpIfSet )
  42 import Outputable
  43 import Maybes           ( maybeToBool )
  44 import List             ( partition )
  45 import Util             ( sortLt )
  46 \end{code}
  47
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 A @CoreRule@ holds details of one rule for an @Id@, which
  56 includes its specialisations.
  57
  58 For example, if a rule for @f@ contains the mapping:
  59 \begin{verbatim}
  60         forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
  61 \end{verbatim}
  62 then when we find an application of f to matching types, we simply replace
  63 it by the matching RHS:
  64 \begin{verbatim}
  65         f (List Int) Bool dict ===>  f' Int Bool
  66 \end{verbatim}
  67 All the stuff about how many dictionaries to discard, and what types
  68 to apply the specialised function to, are handled by the fact that the
  69 Rule contains a template for the result of the specialisation.
  70
  71 There is one more exciting case, which is dealt with in exactly the same
  72 way.  If the specialised value is unboxed then it is lifted at its
  73 definition site and unlifted at its uses.  For example:
  74
  75         pi :: forall a. Num a => a
  76
  77 might have a specialisation
  78
  79         [Int#] ===>  (case pi' of Lift pi# -> pi#)
  80
  81 where pi' :: Lift Int# is the specialised version of pi.
  82
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection{Matching}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
  92 -- See comments on matchRule
  93 matchRules in_scope [] args = Nothing
  94 matchRules in_scope (rule:rules) args
  95   = case matchRule in_scope rule args of
  96         Just result -> Just result
  97         Nothing     -> matchRules in_scope rules args
  98
  99
 100 matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
 101
 102 -- If (matchRule rule args) returns Just (name,rhs,args')
 103 -- then (f args) matches the rule, and the corresponding
 104 -- rewritten RHS is (rhs args').
 105 --
 106 -- The bndrs and rhs is occurrence-analysed
 107 --
 108 --      Example
 109 --
 110 -- The rule
 111 --      forall f g x. map f (map g x) ==> map (f . g) x
 112 -- is stored
 113 --      CoreRule "map/map"
 114 --               [f,g,x]                -- tpl_vars
 115 --               [f,map g x]            -- tpl_args
 116 --               map (f.g) x)           -- rhs
 117 --
 118 -- Then the call: matchRule the_rule [e1,map e2 e3]
 119 --        = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3])
 120 --
 121 -- Any 'surplus' arguments in the input are simply put on the end
 122 -- of the output.
 123 --
 124 -- ASSUMPTION (A):
 125 --      A1. No top-level variable is bound in the target
 126 --      A2. No template variable  is bound in the target
 127 --      A3. No lambda bound template variable is free in any subexpression of the target
 128 --
 129 -- To see why A1 is necessary, consider matching
 130 --      \x->f      against    \f->f
 131 -- When we meet the lambdas we substitute [f/x] in the template (a no-op),
 132 -- and then erroneously succeed in matching f against f.
 133 --
 134 -- To see why A2 is needed consider matching
 135 --      forall a. \b->b    against   \a->3
 136 -- When we meet the lambdas we substitute [a/b] in the template, and then
 137 -- erroneously succeed in matching what looks like the template variable 'a' against 3.
 138 --
 139 -- A3 is needed to validate the rule that says
 140 --      (\x->E) matches F
 141 -- if
 142 --      (\x->E) matches (\x->F x)
 143
 144
 145 matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
 146  = go tpl_args args emptySubst
 147         -- We used to use the in_scope set, but I don't think that's necessary
 148         -- After all, the result is going to be simplified again with that in_scope set
 149  where
 150    tpl_var_set = mkVarSet tpl_vars
 151
 152    -----------------------
 153         -- Do the business
 154    go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
 155
 156         -- Two easy ways to terminate
 157    go []                 []         subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
 158    go []                 args       subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
 159
 160         -- One tiresome way to terminate: check for excess unmatched
 161         -- template arguments
 162    go tpl_args           []         subst
 163       = case eta_complete tpl_args (mkVarSet leftovers) of
 164             Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
 165                                      mk_result_args subst done)
 166             Nothing         -> Nothing  -- Failure
 167       where
 168         (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
 169                                       (map zapOccInfo tpl_vars)
 170                 -- Zap the occ info
 171         subst_env = substEnv subst
 172
 173    -----------------------
 174    eta_complete [] vars = ASSERT( isEmptyVarSet vars )
 175                           Just []
 176    eta_complete (Type ty:tpl_args) vars
 177         = case getTyVar_maybe ty of
 178                 Just tv |  tv `elemVarSet` vars
 179                         -> case eta_complete tpl_args (vars `delVarSet` tv) of
 180                                 Just vars' -> Just (tv:vars')
 181                                 Nothing    -> Nothing
 182                 other   -> Nothing
 183
 184    eta_complete (Var v:tpl_args) vars
 185         | v `elemVarSet` vars
 186         = case eta_complete tpl_args (vars `delVarSet` v) of
 187                 Just vars' -> Just (v:vars')
 188                 Nothing    -> Nothing
 189
 190    eta_complete other vars = Nothing
 191
 192    -----------------------
 193    mk_result_args subst vs = map go vs
 194         where
 195           senv = substEnv subst
 196           go v = case lookupSubstEnv senv v of
 197                         Just (DoneEx ex) -> ex
 198                         Just (DoneTy ty) -> Type ty
 199                         -- Substitution should bind them all!
 200
 201 zapOccInfo bndr | isTyVar bndr = bndr
 202                 | otherwise    = maybeModifyIdInfo zapLamIdInfo bndr
 203 \end{code}
 204
 205 \begin{code}
 206 type Matcher result =  IdOrTyVarSet             -- Template variables
 207                     -> (Subst -> Maybe result)  -- Continuation if success
 208                     -> Subst  -> Maybe result   -- Substitution so far -> result
 209 -- The *SubstEnv* in these Substs apply to the TEMPLATE only
 210
 211 -- The *InScopeSet* in these Substs gives variables bound so far in the
 212 --      target term.  So when matching forall a. (\x. a x) against (\y. y y)
 213 --      while processing the body of the lambdas, the in-scope set will be {y}.
 214 --      That lets us do the occurs-check when matching 'a' against 'y'
 215
 216 match :: CoreExpr               -- Template
 217       -> CoreExpr               -- Target
 218       -> Matcher result
 219
 220 match_fail = Nothing
 221
 222 match (Var v1) e2 tpl_vars kont subst
 223   = case lookupSubst subst v1 of
 224         Nothing | v1 `elemVarSet` tpl_vars      -- v1 is a template variable
 225                 -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
 226                          match_fail             -- Occurs check failure
 227                                                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 228                    else
 229                          kont (extendSubst subst v1 (DoneEx e2))
 230
 231
 232                 | eqExpr (Var v1) e2             -> kont subst
 233                         -- v1 is not a template variable, so it must be a global constant
 234
 235         Just (DoneEx e2')  | eqExpr e2'       e2 -> kont subst
 236
 237         other -> match_fail
 238
 239 match (Con c1 es1) (Con c2 es2) tpl_vars kont subst
 240   | c1 == c2
 241   = matches es1 es2 tpl_vars kont subst
 242
 243 match (App f1 a1) (App f2 a2) tpl_vars kont subst
 244   = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
 245
 246 match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
 247   = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
 248
 249 -- This rule does eta expansion
 250 --              (\x.M)  ~  N    iff     M  ~  N x
 251 -- See assumption A3
 252 match (Lam x1 e1) e2 tpl_vars kont subst
 253   = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
 254
 255 -- Eta expansion the other way
 256 --      M  ~  (\y.N)    iff   \y.M y  ~  \y.N
 257 --                      iff   M y     ~  N
 258 -- Remembering that by (A), y can't be free in M, we get this
 259 match e1 (Lam x2 e2) tpl_vars kont subst
 260   = bind [x2] [x2] (match (App e1 (mkVarArg x2)) e2) tpl_vars kont subst
 261
 262 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
 263   = match e1 e2 tpl_vars case_kont subst
 264   where
 265     case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
 266                                      tpl_vars kont subst
 267
 268 match (Type ty1) (Type ty2) tpl_vars kont subst
 269   = match_ty ty1 ty2 tpl_vars kont subst
 270
 271 match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
 272       tpl_vars kont subst
 273   = (match_ty to1   to2   tpl_vars $
 274      match_ty from1 from2 tpl_vars $
 275      match e1 e2 tpl_vars kont) subst
 276
 277
 278 {-      I don't buy this let-rule any more
 279         The let rule fails on matching
 280                 forall f,x,xs. f (x:xs)
 281         against
 282                 f (let y = e in (y:[]))
 283         because we just get x->y, which is bogus.
 284
 285 -- This is an interesting rule: we simply ignore lets in the
 286 -- term being matched against!  The unfolding inside it is (by assumption)
 287 -- already inside any occurrences of the bound variables, so we'll expand
 288 -- them when we encounter them.  Meanwhile, we can't get false matches because
 289 -- (also by assumption) the term being matched has no shadowing.
 290 match e1 (Let bind e2) tpl_vars kont subst
 291   = match e1 e2 tpl_vars kont subst
 292 -}
 293
 294 -- Here is another important rule: if the term being matched is a
 295 -- variable, we expand it so long as its unfolding is a WHNF
 296 -- (Its occurrence information is not necessarily up to date,
 297 --  so we don't use it.)
 298 match e1 (Var v2) tpl_vars kont subst
 299   = case getIdUnfolding v2 of
 300         CoreUnfolding form guidance unfolding
 301            |  whnfOrBottom form
 302            -> match e1 unfolding tpl_vars kont subst
 303
 304         other -> match_fail
 305
 306 -- We can't cope with lets in the template
 307
 308 match e1 e2 tpl_vars kont subst = match_fail
 309
 310
 311 ------------------------------------------
 312 match_alts [] [] tpl_vars kont subst
 313   = kont subst
 314 match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
 315   | c1 == c2
 316   = bind vs1 vs2 (match r1 r2) tpl_vars
 317                  (match_alts alts1 alts2 tpl_vars kont)
 318                  subst
 319 match_alts alts1 alts2 tpl_vars kont subst = match_fail
 320
 321 lt_alt (con1, _, _) (con2, _, _) = con1 < con2
 322
 323 ----------------------------------------
 324 bind :: [CoreBndr]      -- Template binders
 325      -> [CoreBndr]      -- Target binders
 326      -> Matcher result
 327      -> Matcher result
 328 -- This makes uses of assumption (A) above.  For example,
 329 -- this would fail:
 330 --      Template: (\x.y)        (y is free)
 331 --      Target  : (\y.y)        (y is bound)
 332 -- We rename x to y in the template... but then erroneously
 333 -- match y against y.  But this can't happen because of (A)
 334 bind vs1 vs2 matcher tpl_vars kont subst
 335   = ASSERT( all not_in_subst vs1)
 336     matcher tpl_vars kont' subst'
 337   where
 338     kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
 339     subst'        = bindSubstList subst vs1 vs2
 340
 341         -- The unBindSubst relies on no shadowing in the template
 342     not_in_subst v = not (maybeToBool (lookupSubst subst v))
 343
 344 ----------------------------------------
 345 match_ty ty1 ty2 tpl_vars kont subst
 346   = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of
 347         Nothing    -> match_fail
 348         Just senv' -> kont (setSubstEnv subst senv')
 349
 350 ----------------------------------------
 351 matches [] [] tpl_vars kont subst
 352   = kont subst
 353 matches (e:es) (e':es') tpl_vars kont subst
 354   = match e e' tpl_vars (matches es es' tpl_vars kont) subst
 355 matches es es' tpl_vars kont subst
 356   = match_fail
 357
 358 ----------------------------------------
 359 mkVarArg :: CoreBndr -> CoreArg
 360 mkVarArg v | isId v    = Var v
 361            | otherwise = Type (mkTyVarTy v)
 362 \end{code}
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{Adding a new rule}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 \begin{code}
 371 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
 372
 373 -- Insert the new rule just before a rule that is *less specific*
 374 -- than the new one; or at the end if there isn't such a one.
 375 -- In this way we make sure that when looking up, the first match
 376 -- is the most specific.
 377 --
 378 -- We make no check for rules that unify without one dominating
 379 -- the other.   Arguably this would be a bug.
 380
 381 addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
 382   = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
 383   where
 384     new_rule = Rule str tpl_vars' tpl_args rhs'
 385                 -- Add occ info to tpl_vars, rhs
 386
 387     (rhs_uds, rhs')       = occurAnalyseExpr isLocallyDefined rhs
 388     (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars
 389
 390     insert []                                       = [new_rule]
 391     insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
 392                         | otherwise                 = rule : insert rules
 393
 394     new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
 395
 396     tpl_var_set = mkVarSet tpl_vars'
 397         -- Actually we should probably include the free vars of tpl_args,
 398         -- but I can't be bothered
 399
 400     new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id
 401         -- Hack alert!
 402         -- Don't include the Id in its own rhs free-var set.
 403         -- Otherwise the occurrence analyser makes bindings recursive
 404         -- that shoudn't be.  E.g.
 405         --      RULE:  f (f x y) z  ==>  f x (f y z)
 406
 407 addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
 408 addIdSpecialisations id spec_stuff
 409   = setIdSpecialisation id new_rules
 410   where
 411     rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
 412     new_rules = foldr add (getIdSpecialisation id) spec_stuff
 413     add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
 414 \end{code}
 415
 416
 417 %************************************************************************
 418 %*                                                                      *
 419 \subsection{Preparing the rule base
 420 %*                                                                      *
 421 %************************************************************************
 422
 423 \begin{code}
 424 data ProtoCoreRule
 425   = ProtoCoreRule
 426         Bool            -- True <=> this rule was defined in this module,
 427         Id              -- What Id is it for
 428         CoreRule        -- The rule itself
 429
 430
 431 pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
 432
 433 lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
 434 lookupRule in_scope fn args
 435   = case getIdSpecialisation fn of
 436         Rules rules _ -> matchRules in_scope rules args
 437
 438 orphanRule :: ProtoCoreRule -> Bool
 439 -- An "orphan rule" is one that is defined in this
 440 -- module, but of ran *imported* function.  We need
 441 -- to track these separately when generating the interface file
 442 orphanRule (ProtoCoreRule local fn _)
 443   = local && not (isLocallyDefined fn)
 444 \end{code}
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Getting the rules ready}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 type RuleBase = (IdSet,         -- Imported Ids that have rules attached
 455                  IdSet)         -- Ids (whether local or imported) mentioned on
 456                                 -- LHS of some rule; these should be black listed
 457
 458 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
 459 -- so that the opportunity to apply the rule isn't lost too soon
 460
 461 prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
 462 prepareRuleBase binds rules
 463   = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
 464   where
 465     (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
 466     imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
 467
 468         -- rule_fvs is the set of all variables mentioned in rules
 469     rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
 470
 471         -- Attach the rules for each locally-defined Id to that Id.
 472         --      - This makes the rules easier to look up
 473         --      - It means that transformation rules and specialisations for
 474         --        locally defined Ids are handled uniformly
 475         --      - It keeps alive things that are referred to only from a rule
 476         --        (the occurrence analyser knows about rules attached to Ids)
 477         --      - It makes sure that, when we apply a rule, the free vars
 478         --        of the RHS are more likely to be in scope
 479         --
 480         -- The LHS and RHS Ids are marked 'no-discard'.
 481         -- This means that the binding won't be discarded EVEN if the binding
 482         -- ends up being trivial (v = w) -- the simplifier would usually just
 483         -- substitute w for v throughout, but we don't apply the substitution to
 484         -- the rules (maybe we should?), so this substitution would make the rule
 485         -- bogus.
 486     zap_bind (NonRec b r) = NonRec (zap_bndr b) r
 487     zap_bind (Rec prs)    = Rec [(zap_bndr b, r) | (b,r) <- prs]
 488
 489     zap_bndr bndr = case lookupVarSet rule_ids bndr of
 490                           Just bndr'                           -> setIdNoDiscard bndr'
 491                           Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
 492                                   | otherwise                  -> bndr
 493
 494 add_rule (ProtoCoreRule _ id rule)
 495          (rule_id_set, rule_fvs)
 496   = (rule_id_set `extendVarSet` new_id,
 497      rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
 498   where
 499     new_id = case lookupVarSet rule_id_set id of
 500                 Just id' -> addRuleToId id' rule
 501                 Nothing  -> addRuleToId id  rule
 502     lhs_fvs = ruleSomeLhsFreeVars isId rule
 503         -- Find *all* the free Ids of the LHS, not just
 504         -- locally defined ones!!
 505
 506 addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
 507 \end{code}
 508