Desugar.hs 21.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

The Desugarer: turning HsSyn into Core.
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE CPP #-}
10
{-# LANGUAGE TypeFamilies #-}
11
{-# LANGUAGE ViewPatterns #-}
12

13 14
module Desugar (
    -- * Desugaring operations
15
    deSugar, deSugarExpr
16 17 18
    ) where

#include "HsVersions.h"
19

20 21
import GhcPrelude

22
import DsUsage
Simon Marlow's avatar
Simon Marlow committed
23 24
import DynFlags
import HscTypes
25
import GHC.Hs
Simon Marlow's avatar
Simon Marlow committed
26
import TcRnTypes
Ben Gamari's avatar
Ben Gamari committed
27
import TcRnMonad  ( finalSafeMode, fixSafeInstances )
28
import TcRnDriver ( runTcInteractive )
Simon Marlow's avatar
Simon Marlow committed
29 30
import Id
import Name
31
import Type
32
import Avail
33
import CoreSyn
34 35
import CoreFVs     ( exprsSomeFreeVarsList )
import CoreOpt     ( simpleOptPgm, simpleOptExpr )
Simon Marlow's avatar
Simon Marlow committed
36
import PprCore
37
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
38 39 40
import DsExpr
import DsBinds
import DsForeign
41 42 43 44 45 46 47
import PrelNames   ( coercibleTyConKey )
import TysPrim     ( eqReprPrimTyCon )
import Unique      ( hasKey )
import Coercion    ( mkCoVarCo )
import TysWiredIn  ( coercibleDataCon )
import DataCon     ( dataConWrapId )
import MkCore      ( mkCoreLet )
Simon Marlow's avatar
Simon Marlow committed
48
import Module
49
import NameSet
50
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
51
import Rules
52
import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
53 54
import CoreMonad        ( CoreToDo(..) )
import CoreLint         ( endPassIO )
55
import VarSet
56
import FastString
Simon Marlow's avatar
Simon Marlow committed
57
import ErrUtils
58
import Outputable
Simon Marlow's avatar
Simon Marlow committed
59
import SrcLoc
andy@galois.com's avatar
andy@galois.com committed
60
import Coverage
61
import Util
62 63
import MonadUtils
import OrdList
64
import ExtractDocs
65

66
import Data.List
Simon Marlow's avatar
Simon Marlow committed
67
import Data.IORef
68
import Control.Monad( when )
69
import Plugins ( LoadedPlugin(..) )
70

Austin Seipp's avatar
Austin Seipp committed
71 72 73 74 75 76 77
{-
************************************************************************
*                                                                      *
*              The main function: deSugar
*                                                                      *
************************************************************************
-}
78

79
-- | Main entry point to the desugarer.
80
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
81 82
-- Can modify PCS by faulting in more declarations

83
deSugar hsc_env
andy@galois.com's avatar
andy@galois.com committed
84
        mod_loc
Edward Z. Yang's avatar
Edward Z. Yang committed
85 86
        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
                            tcg_semantic_mod = mod,
87 88 89 90
                            tcg_src          = hsc_src,
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
91
                            tcg_keep         = keep_var,
92 93
                            tcg_th_splice_used = tc_splice_used,
                            tcg_rdr_env      = rdr_env,
94 95 96
                            tcg_fix_env      = fix_env,
                            tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
Edward Z. Yang's avatar
Edward Z. Yang committed
97
                            tcg_merged       = merged,
98 99 100 101
                            tcg_warns        = warns,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,
GregWeber's avatar
GregWeber committed
102
                            tcg_dependent_files = dependent_files,
103
                            tcg_ev_binds     = ev_binds,
104
                            tcg_th_foreign_files = th_foreign_files_var,
105 106
                            tcg_fords        = fords,
                            tcg_rules        = rules,
cactus's avatar
cactus committed
107
                            tcg_patsyns      = patsyns,
108
                            tcg_tcs          = tcs,
109 110
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts,
111 112 113
                            tcg_hpc          = other_hpc_info,
                            tcg_complete_matches = complete_matches
                            })
114

115
  = do { let dflags = hsc_dflags hsc_env
116
             print_unqual = mkPrintUnqualified dflags rdr_env
117
        ; withTiming dflags
118 119 120
                     (text "Desugar"<+>brackets (ppr mod))
                     (const ()) $
     do { -- Desugar the program
121
        ; let export_set = availsToNameSet exports
122 123 124 125
              target     = hscTarget dflags
              hpcInfo    = emptyHpcInfo other_hpc_info

        ; (binds_cvr, ds_hpc_info, modBreaks)
126
                         <- if not (isHsBootOrSig hsc_src)
127 128
                              then addTicksToBinds hsc_env mod mod_loc
                                       export_set (typeEnvTyCons type_env) binds
129
                              else return (binds, hpcInfo, Nothing)
Ben Gamari's avatar
Ben Gamari committed
130
        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
131
                       do { ds_ev_binds <- dsEvBinds ev_binds
132
                          ; core_prs <- dsTopLHsBinds binds_cvr
133
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
134 135
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
136
                          ; let hpc_init
ian@well-typed.com's avatar
ian@well-typed.com committed
137
                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
138
                                  | otherwise = empty
139
                          ; return ( ds_ev_binds
140
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
141
                                   , spec_rules ++ ds_rules
142
                                   , ds_fords `appendStubC` hpc_init) }
143

144 145
        ; case mb_res of {
           Nothing -> return (msgs, Nothing) ;
146
           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
sof's avatar
sof committed
147

148
     do {       -- Add export flags to bindings
149
          keep_alive <- readIORef keep_var
150 151
        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
              final_prs = addExportFlagsAndRules target export_set keep_alive
152
                                                 rules_for_locals (fromOL all_prs)
153 154

              final_pgm = combineEvBinds ds_ev_binds final_prs
155 156 157 158 159
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
        -- When compiling PrelFloat, which defines data Float = F# Float#
        -- we want F# to be in scope in the foreign marshalling code!
        -- You might think it doesn't matter, but the simplifier brings all top-level
        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
160

161
        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
162 163
        ; (ds_binds, ds_rules_for_imps)
            <- simpleOptPgm dflags mod final_pgm rules_for_imps
164
                         -- The simpleOptPgm gets rid of type
165
                         -- bindings plus any stupid dead code
sof's avatar
sof committed
166

167
        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
168

169
        ; let used_names = mkUsedNames tcg_env
170
              pluginModules =
171
                map lpModule (cachedPlugins (hsc_dflags hsc_env))
172
        ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
173
                                 (map mi_module pluginModules) tcg_env
174

175
        ; used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
176
        ; dep_files <- readIORef dependent_files
177
        ; safe_mode <- finalSafeMode dflags tcg_env
178 179
        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
                      dep_files merged pluginModules
Edward Z. Yang's avatar
Edward Z. Yang committed
180 181
        -- id_mod /= mod when we are processing an hsig, but hsigs
        -- never desugared and compiled (there's no code!)
182 183
        -- Consequently, this should hold for any ModGuts that make
        -- past desugaring. See Note [Identity versus semantic module].
Csongor Kiss's avatar
Csongor Kiss committed
184
        ; MASSERT( id_mod == mod )
185

186
        ; foreign_files <- readIORef th_foreign_files_var
187

188 189
        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env

190
        ; let mod_guts = ModGuts {
191
                mg_module       = mod,
192
                mg_hsc_src      = hsc_src,
193
                mg_loc          = mkFileSrcSpan mod_loc,
194
                mg_exports      = exports,
195
                mg_usages       = usages,
196
                mg_deps         = deps,
197
                mg_used_th      = used_th,
198 199 200 201 202
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
                mg_anns         = anns,
                mg_tcs          = tcs,
203
                mg_insts        = fixSafeInstances safe_mode insts,
204 205 206
                mg_fam_insts    = fam_insts,
                mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
207
                mg_patsyns      = patsyns,
208 209
                mg_rules        = ds_rules_for_imps,
                mg_binds        = ds_binds,
210 211
                mg_foreign      = ds_fords,
                mg_foreign_files = foreign_files,
212
                mg_hpc_info     = ds_hpc_info,
213
                mg_modBreaks    = modBreaks,
214
                mg_safe_haskell = safe_mode,
215
                mg_trust_pkg    = imp_trust_own_pkg imports,
216 217 218 219
                mg_complete_sigs = complete_matches,
                mg_doc_hdr      = doc_hdr,
                mg_decl_docs    = decl_docs,
                mg_arg_docs     = arg_docs
220
              }
221
        ; return (msgs, Just mod_guts)
222
        }}}}
223

224 225 226 227 228 229
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
  = case ml_hs_file mod_loc of
      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
      Nothing        -> interactiveSrcSpan   -- Presumably

230 231 232 233 234
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
      ; let (spec_binds, spec_rules) = unzip spec_prs
      ; return (concatOL spec_binds, spec_rules) }
235

batterseapower's avatar
batterseapower committed
236
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
237 238
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
239
combineEvBinds [] val_prs
240
  = [Rec val_prs]
batterseapower's avatar
batterseapower committed
241
combineEvBinds (NonRec b r : bs) val_prs
242 243
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
244
combineEvBinds (Rec prs : bs) val_prs
245 246
  = combineEvBinds bs (prs ++ val_prs)

Austin Seipp's avatar
Austin Seipp committed
247
{-
248 249 250 251
Note [Top-level evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level evidence bindings may be mutually recursive with the top-level value
bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
Gabor Greif's avatar
Gabor Greif committed
252
because the occurrence analyser doesn't take account of type/coercion variables
253
when computing dependencies.
254 255 256

So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
Austin Seipp's avatar
Austin Seipp committed
257
-}
258

259
deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
260

261 262
deSugarExpr hsc_env tc_expr = do {
         let dflags = hsc_dflags hsc_env
263

264
       ; showPass dflags "Desugar"
265

266
         -- Do desugaring
267
       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
268
                                 dsLExpr tc_expr
269

270 271
       ; case mb_core_expr of
            Nothing   -> return ()
272 273
            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
                         (pprCoreExpr expr)
274

275
       ; return (msgs, mb_core_expr) }
276

Austin Seipp's avatar
Austin Seipp committed
277 278 279 280 281 282 283
{-
************************************************************************
*                                                                      *
*              Add rules and export flags to binders
*                                                                      *
************************************************************************
-}
284

285
addExportFlagsAndRules
286
    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
287
    -> [(Id, t)] -> [(Id, t)]
288
addExportFlagsAndRules target exports keep_alive rules prs
289
  = mapFst add_one prs
290
  where
291 292 293 294 295
    add_one bndr = add_rules name (add_export name bndr)
       where
         name = idName bndr

    ---------- Rules --------
296 297 298
        -- See Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas
299
    add_rules name bndr
300 301 302 303
        | Just rules <- lookupNameEnv rule_base name
        = bndr `addIdSpecialisations` rules
        | otherwise
        = bndr
304 305 306 307 308
    rule_base = extendRuleBaseList emptyRuleBase rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    add_export name bndr
309 310
        | dont_discard name = setIdExported bndr
        | otherwise         = bndr
311

312 313
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
314 315 316 317 318 319 320 321 322
                     || name `elemNameSet` keep_alive

        -- In interactive mode, we don't want to discard any top-level
        -- entities at all (eg. do not inline them away during
        -- simplification), and retain them all in the TypeEnv so they are
        -- available from the command line.
        --
        -- isExternalName separates the user-defined top-level names from those
        -- introduced by the type checker.
323
    is_exported :: Name -> Bool
324
    is_exported | targetRetainsAllBindings target = isExternalName
325
                | otherwise                       = (`elemNameSet` exports)
sof's avatar
sof committed
326

Austin Seipp's avatar
Austin Seipp committed
327
{-
328 329
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
330 331 332 333
Set the no-discard flag if either
        a) the Id is exported
        b) it's mentioned in the RHS of an orphan rule
        c) it's in the keep-alive set
334 335

It means that the binding won't be discarded EVEN if the binding
336
ends up being trivial (v = w) -- the simplifier would usually just
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
substitute w for v throughout, but we don't apply the substitution to
the rules (maybe we should?), so this substitution would make the rule
bogus.

You might wonder why exported Ids aren't already marked as such;
it's just because the type checker is rather busy already and
I didn't want to pass in yet another mapping.

Note [Attach rules to local ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Find the rules for locally-defined Ids; then we can attach them
to the binders in the top-level bindings

Reason
  - It makes the rules easier to look up
  - It means that transformation rules and specialisations for
    locally defined Ids are handled uniformly
  - It keeps alive things that are referred to only from a rule
    (the occurrence analyser knows about rules attached to Ids)
  - It makes sure that, when we apply a rule, the free vars
    of the RHS are more likely to be in scope
  - The imported rules are carried in the in-scope set
    which is extended on each iteration by the new wave of
    local binders; any rules which aren't on the binding will
    thereby get dropped

363

Austin Seipp's avatar
Austin Seipp committed
364 365 366 367 368 369
************************************************************************
*                                                                      *
*              Desugaring transformation rules
*                                                                      *
************************************************************************
-}
370

371
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
372 373 374 375 376
dsRule (L loc (HsRule { rd_name = name
                      , rd_act  = rule_act
                      , rd_tmvs = vars
                      , rd_lhs  = lhs
                      , rd_rhs  = rhs }))
377
  = putSrcSpanDs loc $
378
    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
379

ian@well-typed.com's avatar
ian@well-typed.com committed
380
        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
381
                  unsetWOptM Opt_WarnIdentities $
382
                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
383

384
        ; rhs' <- dsLExpr rhs
385
        ; this_mod <- getModule
386

387 388
        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

389 390
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
391 392
        ; dflags <- getDynFlags
        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
393
                Left msg -> do { warnDs NoReason msg; return Nothing } ;
394 395
                Right (final_bndrs, fn_id, args) -> do

396
        { let is_local = isLocalId fn_id
397 398 399 400
                -- NB: isLocalId is False of implicit Ids.  This is good because
                -- we don't want to attach rules to the bindings of implicit Ids,
                -- because they don't show up in the bindings until just before code gen
              fn_name   = idName fn_id
401
              final_rhs = simpleOptExpr dflags rhs''    -- De-crap it
402
              rule_name = snd (unLoc name)
niteria's avatar
niteria committed
403 404 405
              final_bndrs_set = mkVarSet final_bndrs
              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
                        exprsSomeFreeVarsList isId args
406

407 408 409
        ; rule <- dsMkUserRule this_mod is_local
                         rule_name rule_act fn_name final_bndrs args
                         final_rhs
410 411
        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
          warnRuleShadowing rule_name rule_act fn_id arg_ids
412

413 414
        ; return (Just rule)
        } } }
415
dsRule (L _ (XRuleDecl nec)) = noExtCon nec
416 417 418 419 420 421 422 423 424 425 426

warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
warnRuleShadowing rule_name rule_act fn_id arg_ids
  = do { check False fn_id    -- We often have multiple rules for the same Id in a
                              -- module. Maybe we should check that they don't overlap
                              -- but currently we don't
       ; mapM_ (check True) arg_ids }
  where
    check check_rules_too lhs_id
      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
427
                       -- If imported with no unfolding, no worries
428
      , idInlineActivation lhs_id `competesWith` rule_act
429 430
      = warnDs (Reason Opt_WarnInlineRuleShadowing)
               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
431 432 433 434
                               <+> text "may never fire")
                            2 (text "because" <+> quotes (ppr lhs_id)
                               <+> text "might inline first")
                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
435
                       <+> quotes (ppr lhs_id)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
436
                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
437

438 439
      | check_rules_too
      , bad_rule : _ <- get_bad_rules lhs_id
440 441
      = warnDs (Reason Opt_WarnInlineRuleShadowing)
               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
442 443 444 445 446
                               <+> text "may never fire")
                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
                               <+> text "for"<+> quotes (ppr lhs_id)
                               <+> text "might fire first")
                      , text "Probable fix: add phase [n] or [~n] to the competing rule"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
447
                      , whenPprDebug (ppr bad_rule) ])
448 449 450 451 452 453 454

      | otherwise
      = return ()

    get_bad_rules lhs_id
      = [ rule | rule <- idCoreRules lhs_id
               , ruleActivation rule `competesWith` rule_act ]
455 456 457 458 459 460 461 462 463 464

-- See Note [Desugaring coerce as cast]
unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
unfold_coerce bndrs lhs rhs = do
    (bndrs', wrap) <- go bndrs
    return (bndrs', wrap lhs, wrap rhs)
  where
    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
    go []     = return ([], id)
    go (v:vs)
465 466 467 468 469 470 471 472 473 474
        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
        , tc `hasKey` coercibleTyConKey = do
            u <- newUnique

            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
                v'  = mkLocalCoVar
                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
                      [k, t1, t2] `App`
                      Coercion (mkCoVarCo v')
475 476

            (bndrs, wrap) <- go vs
477
            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
478 479 480 481
        | otherwise = do
            (bndrs,wrap) <- go vs
            return (v:bndrs, wrap)

482 483
{- Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
484 485 486 487
For the LHS of a RULE we do *not* want to desugar
    [x]   to    build (\cn. x `c` n)
We want to leave explicit lists simply as chains
of cons's. We can achieve that slightly indirectly by
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
488
switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
489 490

That keeps the desugaring of list comprehensions simple too.
491

492
Nor do we want to warn of conversion identities on the LHS;
493
the rule is precisely to optimise them:
494
  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
495

496 497 498 499 500 501
Note [Desugaring coerce as cast]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want the user to express a rule saying roughly “mapping a coercion over a
list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
be written in Haskell. So we use `coerce` for that (#2110). The user writes
    map coerce = coerce
Gabor Greif's avatar
Gabor Greif committed
502
as a RULE, and this optimizes any kind of mapped' casts away, including `map
503 504 505 506 507 508
MkNewtype`.

For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
`let c = MkCoercible co in ...`. This is later simplified to the desired form
by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
509
See also Note [Getting the map/coerce RULE to work] in CoreSubst.
510

511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
Note [Rules and inlining/other rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have
  f x = ...
  g x = ...
  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
then there's a good chance that in a potential rule redex
    ...f (g e)...
then 'f' or 'g' will inline befor the rule can fire.  Solution: add an
INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.

Note that this applies to all the free variables on the LHS, both the
main function and things in its arguments.

We also check if there are Ids on the LHS that have competing RULES.
In the above example, suppose we had
  {-# RULES "rule-for-g" forally. g [y] = ... #-}
Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
530
active; or perhaps after "rule-for-g" has become inactive. This is checked
531 532 533 534
by 'competesWith'

Class methods have a built-in RULE to select the method from the dictionary,
so you can't change the phase on this.  That makes id very dubious to
535
match on class methods in RULE lhs's.   See #10595.   I'm not happy
536
about this. For example in Control.Arrow we have
537 538 539 540 541 542

{-# RULES "compose/arr"   forall f g .
                          (arr f) . (arr g) = arr (f . g) #-}

and similar, which will elicit exactly these warnings, and risk never
firing.  But it's not clear what to do instead.  We could make the
Gabor Greif's avatar
Gabor Greif committed
543
class method rules inactive in phase 2, but that would delay when
544
subsequent transformations could fire.
Austin Seipp's avatar
Austin Seipp committed
545
-}