Desugar.hs 30.5 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
13
14
15
16
17
18
module Desugar (
    -- * Desugaring operations
    deSugar, deSugarExpr,
    -- * Dependency/fingerprinting code (used by MkIface)
    mkUsageInfo, mkUsedNames, mkDependencies
    ) where

#include "HsVersions.h"
19

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

import Data.Function
69
import Data.List
Simon Marlow's avatar
Simon Marlow committed
70
import Data.IORef
71
import Control.Monad( when )
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
import Data.Map (Map)
import qualified Data.Map as Map

-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
          TcGblEnv{ tcg_mod = mod,
                    tcg_imports = imports,
                    tcg_th_used = th_var
                  }
 = do
      -- Template Haskell used?
      th_used <- readIORef th_var
      let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
                -- M.hi-boot can be in the imp_dep_mods, but we must remove
                -- it before recording the modules on which this one depends!
                -- (We want to retain M.hi-boot in imp_dep_mods so that
                --  loadHiBootInterface can see if M's direct imports depend
                --  on M.hi-boot, and hence that we should do the hi-boot consistency
                --  check.)

          pkgs | th_used   = insertList thUnitId (imp_dep_pkgs imports)
               | otherwise = imp_dep_pkgs imports

          -- Set the packages required to be Safe according to Safe Haskell.
          -- See Note [RnNames . Tracking Trust Transitively]
          sorted_pkgs = sortBy stableUnitIdCmp pkgs
          trust_pkgs  = imp_trust_pkgs imports
          dep_pkgs'   = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs

      return Deps { dep_mods   = sortBy (stableModuleNameCmp `on` fst) dep_mods,
                    dep_pkgs   = dep_pkgs',
                    dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
                    -- sort to get into canonical order
                    -- NB. remember to use lexicographic ordering

mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus

mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
  = do
    eps <- hscEPS hsc_env
    hashes <- mapM getFileHash dependent_files
    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
                                       dir_imp_mods used_names
    let usages = mod_usages ++ [ UsageFile { usg_file_path = f
                                           , usg_file_hash = hash }
                               | (f, hash) <- zip dependent_files hashes ]
    usages `seqList` return usages
    -- seq the list of Usages returned: occasionally these
    -- don't get evaluated for a while and we can end up hanging on to
    -- the entire collection of Ifaces.

mk_mod_usage_info :: PackageIfaceTable
              -> HscEnv
              -> Module
              -> ImportedMods
              -> NameSet
              -> [Usage]
mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
  = mapMaybe mkUsage usage_mods
  where
    hpt = hsc_HPT hsc_env
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

    used_mods    = moduleEnvKeys ent_map
    dir_imp_mods = moduleEnvKeys direct_imports
    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
    usage_mods   = sortBy stableModuleCmp all_mods
                        -- canonical order is imported, to avoid interface-file
                        -- wobblage.

    -- ent_map groups together all the things imported and used
    -- from a particular module
    ent_map :: ModuleEnv [OccName]
    ent_map  = foldNameSet add_mv emptyModuleEnv used_names
     where
      add_mv name mv_map
        | isWiredInName name = mv_map  -- ignore wired-in names
        | otherwise
        = case nameModule_maybe name of
             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
                -- See Note [Internal used_names]

             Just mod -> -- This lambda function is really just a
                         -- specialised (++); originally came about to
                         -- avoid quadratic behaviour (trac #2680)
                         extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
                where occ = nameOccName name

    -- We want to create a Usage for a home module if
    --  a) we used something from it; has something in used_names
    --  b) we imported it, even if we used nothing from it
    --     (need to recompile if its export list changes: export_fprint)
    mkUsage :: Module -> Maybe Usage
    mkUsage mod
      | isNothing maybe_iface           -- We can't depend on it if we didn't
                                        -- load its interface.
      || mod == this_mod                -- We don't care about usages of
                                        -- things in *this* module
      = Nothing

      | moduleUnitId mod /= this_pkg
      = Just UsagePackageModule{ usg_mod      = mod,
                                 usg_mod_hash = mod_hash,
                                 usg_safe     = imp_safe }
        -- for package modules, we record the module hash only

      | (null used_occs
          && isNothing export_hash
          && not is_direct_import
          && not finsts_mod)
      = Nothing                 -- Record no usage info
        -- for directly-imported modules, we always want to record a usage
        -- on the orphan hash.  This is what triggers a recompilation if
        -- an orphan is added or removed somewhere below us in the future.

      | otherwise
      = Just UsageHomeModule {
                      usg_mod_name = moduleName mod,
                      usg_mod_hash = mod_hash,
                      usg_exports  = export_hash,
                      usg_entities = Map.toList ent_hashs,
                      usg_safe     = imp_safe }
      where
        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
                -- In one-shot mode, the interfaces for home-package
                -- modules accumulate in the PIT not HPT.  Sigh.

        Just iface   = maybe_iface
        finsts_mod   = mi_finsts    iface
        hash_env     = mi_hash_fn   iface
        mod_hash     = mi_mod_hash  iface
        export_hash | depend_on_exports = Just (mi_exp_hash iface)
                    | otherwise         = Nothing

        (is_direct_import, imp_safe)
            = case lookupModuleEnv direct_imports mod of
                Just (imv : _xs) -> (True, imv_is_safe imv)
                Just _           -> pprPanic "mkUsage: empty direct import" Outputable.empty
                Nothing          -> (False, safeImplicitImpsReq dflags)
                -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
                -- is used in the source code. We require them to be safe in Safe Haskell

        used_occs = lookupModuleEnv ent_map mod `orElse` []

        -- Making a Map here ensures that (a) we remove duplicates
        -- when we have usages on several subordinates of a single parent,
        -- and (b) that the usages emerge in a canonical order, which
        -- is why we use Map rather than OccEnv: Map works
        -- using Ord on the OccNames, which is a lexicographic ordering.
        ent_hashs :: Map OccName Fingerprint
        ent_hashs = Map.fromList (map lookup_occ used_occs)

        lookup_occ occ =
            case hash_env occ of
                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
                Just r  -> r

        depend_on_exports = is_direct_import
        {- True
              Even if we used 'import M ()', we have to register a
              usage on the export list because we are sensitive to
              changes in orphan instances/rules.
           False
              In GHC 6.8.x we always returned true, and in
              fact it recorded a dependency on *all* the
              modules underneath in the dependency tree.  This
              happens to make orphans work right, but is too
              expensive: it'll read too many interface files.
              The 'isNothing maybe_iface' check above saved us
              from generating many of these usages (at least in
              one-shot mode), but that's even more bogus!
        -}
250

Austin Seipp's avatar
Austin Seipp committed
251
252
253
254
255
256
257
{-
************************************************************************
*                                                                      *
*              The main function: deSugar
*                                                                      *
************************************************************************
-}
258

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

263
deSugar hsc_env
andy@galois.com's avatar
andy@galois.com committed
264
        mod_loc
265
        tcg_env@(TcGblEnv { tcg_mod          = mod,
266
267
268
269
                            tcg_src          = hsc_src,
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
270
                            tcg_keep         = keep_var,
271
272
                            tcg_th_splice_used = tc_splice_used,
                            tcg_rdr_env      = rdr_env,
273
274
275
276
277
278
279
                            tcg_fix_env      = fix_env,
                            tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
                            tcg_warns        = warns,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,
GregWeber's avatar
GregWeber committed
280
                            tcg_dependent_files = dependent_files,
281
282
283
284
                            tcg_ev_binds     = ev_binds,
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_vects        = vects,
Gergő Érdi's avatar
Gergő Érdi committed
285
                            tcg_patsyns      = patsyns,
286
                            tcg_tcs          = tcs,
287
288
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts,
Facundo Domínguez's avatar
Facundo Domínguez committed
289
                            tcg_hpc          = other_hpc_info})
290

291
  = do { let dflags = hsc_dflags hsc_env
292
             print_unqual = mkPrintUnqualified dflags rdr_env
293
294
295
296
        ; withTiming (pure dflags)
                     (text "Desugar"<+>brackets (ppr mod))
                     (const ()) $
     do { -- Desugar the program
297
        ; let export_set = availsToNameSet exports
298
299
300
301
              target     = hscTarget dflags
              hpcInfo    = emptyHpcInfo other_hpc_info

        ; (binds_cvr, ds_hpc_info, modBreaks)
302
                         <- if not (isHsBootOrSig hsc_src)
303
304
                              then addTicksToBinds hsc_env mod mod_loc
                                       export_set (typeEnvTyCons type_env) binds
305
                              else return (binds, hpcInfo, Nothing)
306

307
        ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
308
                       do { ds_ev_binds <- dsEvBinds ev_binds
309
                          ; core_prs <- dsTopLHsBinds binds_cvr
310
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
311
312
313
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
                          ; ds_vects <- mapM dsVect vects
314
                          ; let hpc_init
ian@well-typed.com's avatar
ian@well-typed.com committed
315
                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
316
                                  | otherwise = empty
317
                          ; return ( ds_ev_binds
318
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
319
                                   , spec_rules ++ ds_rules, ds_vects
320
                                   , ds_fords `appendStubC` hpc_init) }
321

322
323
        ; case mb_res of {
           Nothing -> return (msgs, Nothing) ;
324
           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
sof's avatar
sof committed
325

326
     do {       -- Add export flags to bindings
327
          keep_alive <- readIORef keep_var
328
329
330
        ; 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)
331
332

              final_pgm = combineEvBinds ds_ev_binds final_prs
333
334
335
336
337
        -- 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#!
338

339
#ifdef DEBUG
dimitris's avatar
dimitris committed
340
          -- Debug only as pre-simple-optimisation program may be really big
341
        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
342
#endif
343
        ; (ds_binds, ds_rules_for_imps, ds_vects)
344
            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
345
                         -- The simpleOptPgm gets rid of type
346
                         -- bindings plus any stupid dead code
sof's avatar
sof committed
347

348
        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
349

350
        ; let used_names = mkUsedNames tcg_env
351
        ; deps <- mkDependencies tcg_env
Simon Marlow's avatar
Simon Marlow committed
352

353
        ; used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
354
        ; dep_files <- readIORef dependent_files
355
        ; safe_mode <- finalSafeMode dflags tcg_env
356
        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files
357
358

        ; let mod_guts = ModGuts {
359
                mg_module       = mod,
360
                mg_hsc_src      = hsc_src,
361
                mg_loc          = mkFileSrcSpan mod_loc,
362
                mg_exports      = exports,
363
                mg_usages       = usages,
364
                mg_deps         = deps,
365
                mg_used_th      = used_th,
366
367
368
369
370
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
                mg_anns         = anns,
                mg_tcs          = tcs,
371
                mg_insts        = fixSafeInstances safe_mode insts,
372
373
374
                mg_fam_insts    = fam_insts,
                mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
375
                mg_patsyns      = patsyns,
376
377
378
379
                mg_rules        = ds_rules_for_imps,
                mg_binds        = ds_binds,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
380
                mg_modBreaks    = modBreaks,
381
                mg_vect_decls   = ds_vects,
382
                mg_vect_info    = noVectInfo,
383
                mg_safe_haskell = safe_mode,
384
                mg_trust_pkg    = imp_trust_own_pkg imports
385
              }
386
        ; return (msgs, Just mod_guts)
387
        }}}}
388

389
390
391
392
393
394
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
  = case ml_hs_file mod_loc of
      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
      Nothing        -> interactiveSrcSpan   -- Presumably

395
396
397
398
399
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) }
400

batterseapower's avatar
batterseapower committed
401
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
402
403
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
404
combineEvBinds [] val_prs
405
  = [Rec val_prs]
batterseapower's avatar
batterseapower committed
406
combineEvBinds (NonRec b r : bs) val_prs
407
408
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
409
combineEvBinds (Rec prs : bs) val_prs
410
411
  = combineEvBinds bs (prs ++ val_prs)

Austin Seipp's avatar
Austin Seipp committed
412
{-
413
414
415
416
417
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
418
when computing dependencies.
419
420
421

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

424
425
426
427
428
429
430
431
432
433
deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)

deSugarExpr hsc_env tc_expr
  = do { let dflags       = hsc_dflags hsc_env
             icntxt       = hsc_IC hsc_env
             rdr_env      = ic_rn_gbl_env icntxt
             type_env     = mkTypeEnvWithImplicits (ic_tythings icntxt)
             fam_insts    = snd (ic_instances icntxt)
             fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
             -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
434

435
       ; showPass dflags "Desugar"
436

437
         -- Do desugaring
438
       ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
439
                                        type_env fam_inst_env $
440
                                 dsLExpr tc_expr
441

442
443
444
       ; case mb_core_expr of
            Nothing   -> return ()
            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
445

446
       ; return (msgs, mb_core_expr) }
447

Austin Seipp's avatar
Austin Seipp committed
448
449
450
451
452
453
454
{-
************************************************************************
*                                                                      *
*              Add rules and export flags to binders
*                                                                      *
************************************************************************
-}
455

456
addExportFlagsAndRules
457
458
459
460
    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
    -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules target exports keep_alive rules prs
  = mapFst add_one prs
461
  where
462
463
464
465
466
    add_one bndr = add_rules name (add_export name bndr)
       where
         name = idName bndr

    ---------- Rules --------
467
468
469
        -- See Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas
470
    add_rules name bndr
471
472
473
474
        | Just rules <- lookupNameEnv rule_base name
        = bndr `addIdSpecialisations` rules
        | otherwise
        = bndr
475
476
477
478
479
    rule_base = extendRuleBaseList emptyRuleBase rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    add_export name bndr
480
481
        | dont_discard name = setIdExported bndr
        | otherwise         = bndr
482

483
484
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
485
486
487
488
489
490
491
492
493
                     || 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.
494
    is_exported :: Name -> Bool
495
496
    is_exported | targetRetainsAllBindings target = isExternalName
                | otherwise                       = (`elemNameSet` exports)
sof's avatar
sof committed
497

Austin Seipp's avatar
Austin Seipp committed
498
{-
499
500
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
501
502
503
504
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
505
506

It means that the binding won't be discarded EVEN if the binding
507
ends up being trivial (v = w) -- the simplifier would usually just
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
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

534

Austin Seipp's avatar
Austin Seipp committed
535
536
537
538
539
540
************************************************************************
*                                                                      *
*              Desugaring transformation rules
*                                                                      *
************************************************************************
-}
541

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

ian@well-typed.com's avatar
ian@well-typed.com committed
547
        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
548
                  unsetWOptM Opt_WarnIdentities $
549
                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
550

551
        ; rhs' <- dsLExpr rhs
552
        ; this_mod <- getModule
553

554
555
        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

556
557
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
558
        ; case decomposeRuleLhs bndrs'' lhs'' of {
559
                Left msg -> do { warnDs NoReason msg; return Nothing } ;
560
561
562
563
564
565
566
                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
567
              final_rhs = simpleOptExpr rhs''    -- De-crap it
568
              rule_name = snd (unLoc name)
niteria's avatar
niteria committed
569
570
571
              final_bndrs_set = mkVarSet final_bndrs
              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
                        exprsSomeFreeVarsList isId args
572
573

        ; dflags <- getDynFlags
574
575
576
        ; rule <- dsMkUserRule this_mod is_local
                         rule_name rule_act fn_name final_bndrs args
                         final_rhs
577
578
        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
          warnRuleShadowing rule_name rule_act fn_id arg_ids
579

580
581
582
583
584
585
586
587
588
589
590
591
592
593
        ; 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)
594
                       -- If imported with no unfolding, no worries
595
      , idInlineActivation lhs_id `competesWith` rule_act
596
597
      = warnDs (Reason Opt_WarnInlineRuleShadowing)
               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
598
599
600
601
                               <+> 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"
602
603
                       <+> quotes (ppr lhs_id)
                     , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
604

605
606
      | check_rules_too
      , bad_rule : _ <- get_bad_rules lhs_id
607
608
      = warnDs (Reason Opt_WarnInlineRuleShadowing)
               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
609
610
611
612
613
                               <+> 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"
614
615
616
617
618
619
620
621
                      , ifPprDebug (ppr bad_rule) ])

      | otherwise
      = return ()

    get_bad_rules lhs_id
      = [ rule | rule <- idCoreRules lhs_id
               , ruleActivation rule `competesWith` rule_act ]
622
623
624
625
626
627
628
629
630
631

-- 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)
632
633
634
635
636
637
638
639
640
641
        | 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')
642
643

            (bndrs, wrap) <- go vs
644
            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
645
646
647
648
        | otherwise = do
            (bndrs,wrap) <- go vs
            return (v:bndrs, wrap)

649
650
{- Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
651
652
653
654
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
655
switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
656
657

That keeps the desugaring of list comprehensions simple too.
658

659
660
661
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 #-}
662

663
664
665
666
667
668
669
670
671
672
673
674
675
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
as a RULE, and this optimizes any kind of mapped' casts aways, including `map
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).
676
See also Note [Getting the map/coerce RULE to work] in CoreSubst.
677

678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
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
about this. For exmaple in Control.Arrow we have

{-# 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
714
715
716
717
718
719
************************************************************************
*                                                                      *
*              Desugaring vectorisation declarations
*                                                                      *
************************************************************************
-}
720
721

dsVect :: LVectDecl Id -> DsM CoreVect
Alan Zimmerman's avatar
Alan Zimmerman committed
722
dsVect (L loc (HsVect _ (L _ v) rhs))
723
  = putSrcSpanDs loc $
724
    do { rhs' <- dsLExpr rhs
725
       ; return $ Vect v rhs'
726
       }
Alan Zimmerman's avatar
Alan Zimmerman committed
727
dsVect (L _loc (HsNoVect _ (L _ v)))
728
  = return $ NoVect v
729
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
730
731
732
733
734
  = 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
735
dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
736
  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
737
738
dsVect (L _loc (HsVectClassOut cls))
  = return $ VectClass (classTyCon cls)
Alan Zimmerman's avatar
Alan Zimmerman committed
739
dsVect vc@(L _ (HsVectClassIn _ _))
740
  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
741
742
743
dsVect (L _loc (HsVectInstOut inst))
  = return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
744
  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)