Desugar.hs 22.7 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 10
{-# LANGUAGE CPP #-}

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

#include "HsVersions.h"
17

18
import DsUsage
Simon Marlow's avatar
Simon Marlow committed
19 20 21 22
import DynFlags
import HscTypes
import HsSyn
import TcRnTypes
Ben Gamari's avatar
Ben Gamari committed
23
import TcRnMonad  ( finalSafeMode, fixSafeInstances )
24
import TcRnDriver ( runTcInteractive )
Simon Marlow's avatar
Simon Marlow committed
25 26
import Id
import Name
27
import Type
28 29
import InstEnv
import Class
30
import Avail
31
import CoreSyn
32 33
import CoreFVs     ( exprsSomeFreeVarsList )
import CoreOpt     ( simpleOptPgm, simpleOptExpr )
Simon Marlow's avatar
Simon Marlow committed
34
import PprCore
35
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
36 37 38
import DsExpr
import DsBinds
import DsForeign
39 40 41 42 43 44 45
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
46
import Module
47
import NameSet
48
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
49
import Rules
50
import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
51 52
import CoreMonad        ( CoreToDo(..) )
import CoreLint         ( endPassIO )
53
import VarSet
54
import FastString
Simon Marlow's avatar
Simon Marlow committed
55
import ErrUtils
56
import Outputable
Simon Marlow's avatar
Simon Marlow committed
57
import SrcLoc
andy@galois.com's avatar
andy@galois.com committed
58
import Coverage
59
import Util
60 61
import MonadUtils
import OrdList
62

63
import Data.List
Simon Marlow's avatar
Simon Marlow committed
64
import Data.IORef
65
import Control.Monad( when )
66

Austin Seipp's avatar
Austin Seipp committed
67 68 69 70 71 72 73
{-
************************************************************************
*                                                                      *
*              The main function: deSugar
*                                                                      *
************************************************************************
-}
74

Thomas Schilling's avatar
Thomas Schilling committed
75
-- | Main entry point to the desugarer.
76
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
77 78
-- Can modify PCS by faulting in more declarations

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

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

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

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

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

              final_pgm = combineEvBinds ds_ev_binds final_prs
153 154 155 156 157
        -- 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#!
158

159
#ifdef DEBUG
dimitris's avatar
dimitris committed
160
          -- Debug only as pre-simple-optimisation program may be really big
161
        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
162
#endif
163
        ; (ds_binds, ds_rules_for_imps, ds_vects)
164
            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
165
                         -- The simpleOptPgm gets rid of type
166
                         -- bindings plus any stupid dead code
sof's avatar
sof committed
167

168
        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
169

170
        ; let used_names = mkUsedNames tcg_env
171
        ; deps <- mkDependencies tcg_env
Simon Marlow's avatar
Simon Marlow committed
172

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

183
        ; foreign_files <- readIORef th_foreign_files_var
184

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

218 219 220 221 222 223
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
  = case ml_hs_file mod_loc of
      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
      Nothing        -> interactiveSrcSpan   -- Presumably

224 225 226 227 228
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) }
229

batterseapower's avatar
batterseapower committed
230
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
231 232
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
233
combineEvBinds [] val_prs
234
  = [Rec val_prs]
batterseapower's avatar
batterseapower committed
235
combineEvBinds (NonRec b r : bs) val_prs
236 237
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
238
combineEvBinds (Rec prs : bs) val_prs
239 240
  = combineEvBinds bs (prs ++ val_prs)

Austin Seipp's avatar
Austin Seipp committed
241
{-
242 243 244 245 246
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
because the occurrence analyser doesn't teke account of type/coercion variables
247
when computing dependencies.
248 249 250

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

253 254
deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)

255 256
deSugarExpr hsc_env tc_expr = do {
         let dflags = hsc_dflags hsc_env
257

258
       ; showPass dflags "Desugar"
259

260
         -- Do desugaring
261
       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
262
                                 dsLExpr tc_expr
263

264 265
       ; case mb_core_expr of
            Nothing   -> return ()
266 267
            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
                         (pprCoreExpr expr)
268

269
       ; return (msgs, mb_core_expr) }
270

Austin Seipp's avatar
Austin Seipp committed
271 272 273 274 275 276 277
{-
************************************************************************
*                                                                      *
*              Add rules and export flags to binders
*                                                                      *
************************************************************************
-}
278

279
addExportFlagsAndRules
280 281 282 283
    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
    -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules target exports keep_alive rules prs
  = mapFst add_one prs
284
  where
285 286 287 288 289
    add_one bndr = add_rules name (add_export name bndr)
       where
         name = idName bndr

    ---------- Rules --------
290 291 292
        -- See Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas
293
    add_rules name bndr
294 295 296 297
        | Just rules <- lookupNameEnv rule_base name
        = bndr `addIdSpecialisations` rules
        | otherwise
        = bndr
298 299 300 301 302
    rule_base = extendRuleBaseList emptyRuleBase rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    add_export name bndr
303 304
        | dont_discard name = setIdExported bndr
        | otherwise         = bndr
305

306 307
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
308 309 310 311 312 313 314 315 316
                     || 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.
317
    is_exported :: Name -> Bool
318 319
    is_exported | targetRetainsAllBindings target = isExternalName
                | otherwise                       = (`elemNameSet` exports)
sof's avatar
sof committed
320

Austin Seipp's avatar
Austin Seipp committed
321
{-
322 323
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
324 325 326 327
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
328 329

It means that the binding won't be discarded EVEN if the binding
330
ends up being trivial (v = w) -- the simplifier would usually just
331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
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

357

Austin Seipp's avatar
Austin Seipp committed
358 359 360 361 362 363
************************************************************************
*                                                                      *
*              Desugaring transformation rules
*                                                                      *
************************************************************************
-}
364

Simon Marlow's avatar
Simon Marlow committed
365
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
366
dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
367
  = putSrcSpanDs loc $
368
    do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
369

ian@well-typed.com's avatar
ian@well-typed.com committed
370
        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
371
                  unsetWOptM Opt_WarnIdentities $
372
                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
373

374
        ; rhs' <- dsLExpr rhs
375
        ; this_mod <- getModule
376

377 378
        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

379 380
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
381
        ; case decomposeRuleLhs bndrs'' lhs'' of {
382
                Left msg -> do { warnDs NoReason msg; return Nothing } ;
383 384 385 386 387 388 389
                Right (final_bndrs, fn_id, args) -> do

        { let is_local = isLocalId fn_id
                -- 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
390
              final_rhs = simpleOptExpr rhs''    -- De-crap it
391
              rule_name = snd (unLoc name)
niteria's avatar
niteria committed
392 393 394
              final_bndrs_set = mkVarSet final_bndrs
              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
                        exprsSomeFreeVarsList isId args
395 396

        ; dflags <- getDynFlags
397 398 399
        ; rule <- dsMkUserRule this_mod is_local
                         rule_name rule_act fn_name final_bndrs args
                         final_rhs
400 401
        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
          warnRuleShadowing rule_name rule_act fn_id arg_ids
402

403 404 405 406 407 408 409 410 411 412 413 414 415 416
        ; return (Just rule)
        } } }


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)
417
                       -- If imported with no unfolding, no worries
418
      , idInlineActivation lhs_id `competesWith` rule_act
419 420
      = warnDs (Reason Opt_WarnInlineRuleShadowing)
               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
421 422 423 424
                               <+> 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"
425 426
                       <+> quotes (ppr lhs_id)
                     , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
427

428 429
      | check_rules_too
      , bad_rule : _ <- get_bad_rules lhs_id
430 431
      = warnDs (Reason Opt_WarnInlineRuleShadowing)
               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
432 433 434 435 436
                               <+> 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"
437 438 439 440 441 442 443 444
                      , ifPprDebug (ppr bad_rule) ])

      | otherwise
      = return ()

    get_bad_rules lhs_id
      = [ rule | rule <- idCoreRules lhs_id
               , ruleActivation rule `competesWith` rule_act ]
445 446 447 448 449 450 451 452 453 454

-- 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)
455 456 457 458 459 460 461 462 463 464
        | 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')
465 466

            (bndrs, wrap) <- go vs
467
            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
468 469 470 471
        | otherwise = do
            (bndrs,wrap) <- go vs
            return (v:bndrs, wrap)

472 473
{- Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
474 475 476 477
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
478
switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
479 480

That keeps the desugaring of list comprehensions simple too.
481

482 483 484
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
485

486 487 488 489 490 491
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
492
as a RULE, and this optimizes any kind of mapped' casts away, including `map
493 494 495 496 497 498
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).
499
See also Note [Getting the map/coerce RULE to work] in CoreSubst.
500

501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
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
active; or perhpas after "rule-for-g" has become inactive. This is checked
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
match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy
Gabor Greif's avatar
Gabor Greif committed
526
about this. For example in Control.Arrow we have
527 528 529 530 531 532 533 534 535 536

{-# 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
class methocd rules inactive in phase 2, but that would delay when
subsequent transformations could fire.


Austin Seipp's avatar
Austin Seipp committed
537 538 539 540 541 542
************************************************************************
*                                                                      *
*              Desugaring vectorisation declarations
*                                                                      *
************************************************************************
-}
543 544

dsVect :: LVectDecl Id -> DsM CoreVect
Alan Zimmerman's avatar
Alan Zimmerman committed
545
dsVect (L loc (HsVect _ (L _ v) rhs))
546
  = putSrcSpanDs loc $
547
    do { rhs' <- dsLExpr rhs
548
       ; return $ Vect v rhs'
549
       }
Alan Zimmerman's avatar
Alan Zimmerman committed
550
dsVect (L _loc (HsNoVect _ (L _ v)))
551
  = return $ NoVect v
552
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
553 554 555 556 557
  = return $ VectType isScalar tycon' rhs_tycon
  where
    tycon' | Just ty <- coreView $ mkTyConTy tycon
           , (tycon', []) <- splitTyConApp ty      = tycon'
           | otherwise                             = tycon
Alan Zimmerman's avatar
Alan Zimmerman committed
558
dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
559
  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
560 561
dsVect (L _loc (HsVectClassOut cls))
  = return $ VectClass (classTyCon cls)
Alan Zimmerman's avatar
Alan Zimmerman committed
562
dsVect vc@(L _ (HsVectClassIn _ _))
563
  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
564 565 566
dsVect (L _loc (HsVectInstOut inst))
  = return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
567
  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)