HsToCore.hs 31.2 KB
Newer Older
1

2
3
4
5
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

Austin Seipp's avatar
Austin Seipp committed
6
7
8
9
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
10
11

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

14
module GHC.HsToCore (
15
    -- * Desugaring operations
16
    deSugar, deSugarExpr
17
18
    ) where

19
import GHC.Prelude
20

Sylvain Henry's avatar
Sylvain Henry committed
21
import GHC.Driver.Session
22
import GHC.Driver.Config
23
import GHC.Driver.Config.HsToCore.Usage
Sylvain Henry's avatar
Sylvain Henry committed
24
import GHC.Driver.Env
Sylvain Henry's avatar
Sylvain Henry committed
25
import GHC.Driver.Backend
26
import GHC.Driver.Plugins
Sylvain Henry's avatar
Sylvain Henry committed
27

Sylvain Henry's avatar
Sylvain Henry committed
28
import GHC.Hs
Sylvain Henry's avatar
Sylvain Henry committed
29
30
31

import GHC.HsToCore.Usage
import GHC.HsToCore.Monad
32
import GHC.HsToCore.Errors.Types
Sylvain Henry's avatar
Sylvain Henry committed
33
34
35
36
37
38
import GHC.HsToCore.Expr
import GHC.HsToCore.Binds
import GHC.HsToCore.Foreign.Decl
import GHC.HsToCore.Coverage
import GHC.HsToCore.Docs

Sylvain Henry's avatar
Sylvain Henry committed
39
40
41
import GHC.Tc.Types
import GHC.Tc.Utils.Monad  ( finalSafeMode, fixSafeInstances )
import GHC.Tc.Module ( runTcInteractive )
Sylvain Henry's avatar
Sylvain Henry committed
42

Sylvain Henry's avatar
Sylvain Henry committed
43
44
import GHC.Core.Type
import GHC.Core.TyCon     ( tyConDataCons )
Sylvain Henry's avatar
Sylvain Henry committed
45
46
47
48
import GHC.Core
import GHC.Core.FVs       ( exprsSomeFreeVarsList )
import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
import GHC.Core.Utils
49
import GHC.Core.Unfold.Make
Sylvain Henry's avatar
Sylvain Henry committed
50
51
import GHC.Core.Coercion
import GHC.Core.DataCon ( dataConWrapId )
Sylvain Henry's avatar
Sylvain Henry committed
52
53
import GHC.Core.Make
import GHC.Core.Rules
Sylvain Henry's avatar
Sylvain Henry committed
54
import GHC.Core.Opt.Monad ( CoreToDo(..) )
55
import GHC.Core.Lint     ( endPassIO )
56
import GHC.Core.Ppr
Sylvain Henry's avatar
Sylvain Henry committed
57
58
59
60
61

import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types

62
import GHC.Data.FastString
63
import GHC.Data.Maybe    ( expectJust )
Sylvain Henry's avatar
Sylvain Henry committed
64
65
import GHC.Data.OrdList

66
67
import GHC.Utils.Error
import GHC.Utils.Outputable
68
import GHC.Utils.Panic.Plain
69
70
import GHC.Utils.Misc
import GHC.Utils.Monad
Sylvain Henry's avatar
Sylvain Henry committed
71
import GHC.Utils.Logger
Sylvain Henry's avatar
Sylvain Henry committed
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.ForeignStubs
import GHC.Types.Avail
import GHC.Types.Basic
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.TypeEnv
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.HpcInfo

import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
91
import GHC.Unit.Module.Deps
92

93
import Data.List (partition)
Simon Marlow's avatar
Simon Marlow committed
94
import Data.IORef
95

Austin Seipp's avatar
Austin Seipp committed
96
97
98
99
100
101
102
{-
************************************************************************
*                                                                      *
*              The main function: deSugar
*                                                                      *
************************************************************************
-}
103

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

108
deSugar hsc_env
andy@galois.com's avatar
andy@galois.com committed
109
        mod_loc
Edward Z. Yang's avatar
Edward Z. Yang committed
110
111
        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
                            tcg_semantic_mod = mod,
112
113
114
115
                            tcg_src          = hsc_src,
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
116
                            tcg_keep         = keep_var,
117
118
                            tcg_th_splice_used = tc_splice_used,
                            tcg_rdr_env      = rdr_env,
119
120
121
                            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
122
                            tcg_merged       = merged,
123
124
125
126
                            tcg_warns        = warns,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,
GregWeber's avatar
GregWeber committed
127
                            tcg_dependent_files = dependent_files,
128
                            tcg_ev_binds     = ev_binds,
129
                            tcg_th_foreign_files = th_foreign_files_var,
130
131
                            tcg_fords        = fords,
                            tcg_rules        = rules,
Gergő Érdi's avatar
Gergő Érdi committed
132
                            tcg_patsyns      = patsyns,
133
                            tcg_tcs          = tcs,
134
135
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts,
136
                            tcg_hpc          = other_hpc_info,
Andreas Klebinger's avatar
Andreas Klebinger committed
137
138
                            tcg_complete_matches = complete_matches,
                            tcg_self_boot    = self_boot
139
                            })
140

141
  = do { let dflags = hsc_dflags hsc_env
Sylvain Henry's avatar
Sylvain Henry committed
142
             logger = hsc_logger hsc_env
143
             print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
144
        ; withTiming logger
145
146
147
                     (text "Desugar"<+>brackets (ppr mod))
                     (const ()) $
     do { -- Desugar the program
148
        ; let export_set = availsToNameSet exports
Sylvain Henry's avatar
Sylvain Henry committed
149
              bcknd      = backend dflags
150
151
152
              hpcInfo    = emptyHpcInfo other_hpc_info

        ; (binds_cvr, ds_hpc_info, modBreaks)
153
                         <- if not (isHsBootOrSig hsc_src)
154
                              then addTicksToBinds
John Ericson's avatar
John Ericson committed
155
156
157
158
159
160
                                       (CoverageConfig
                                        { coverageConfig_logger = hsc_logger hsc_env
                                        , coverageConfig_dynFlags = hsc_dflags hsc_env
                                        , coverageConfig_mInterp = hsc_interp hsc_env
                                        })
                                       mod mod_loc
161
                                       export_set (typeEnvTyCons type_env) binds
162
                              else return (binds, hpcInfo, Nothing)
Ben Gamari's avatar
Ben Gamari committed
163
        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
164
                       do { ds_ev_binds <- dsEvBinds ev_binds
165
                          ; core_prs <- dsTopLHsBinds binds_cvr
166
                          ; core_prs <- patchMagicDefns core_prs
167
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
168
169
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
170
                          ; let hpc_init
171
                                  | gopt Opt_Hpc dflags = hpcInitCode (targetPlatform $ hsc_dflags hsc_env) mod ds_hpc_info
172
                                  | otherwise = mempty
173
                          ; return ( ds_ev_binds
174
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
175
                                   , spec_rules ++ ds_rules
176
                                   , ds_fords `appendStubC` hpc_init) }
177

178
179
        ; case mb_res of {
           Nothing -> return (msgs, Nothing) ;
180
           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
sof's avatar
sof committed
181

182
     do {       -- Add export flags to bindings
183
          keep_alive <- readIORef keep_var
184
        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
Sylvain Henry's avatar
Sylvain Henry committed
185
              final_prs = addExportFlagsAndRules bcknd export_set keep_alive
186
                                                 rules_for_locals (fromOL all_prs)
187
188

              final_pgm = combineEvBinds ds_ev_binds final_prs
189
190
191
192
193
        -- 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#!
194

195
        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
196
        ; let simpl_opts = initSimpleOpts dflags
197
198
        ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
                = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
199
                         -- The simpleOptPgm gets rid of type
200
                         -- bindings plus any stupid dead code
201
        ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
202
            FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
sof's avatar
sof committed
203

204
        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
205

206
        ; let used_names = mkUsedNames tcg_env
207
              pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
208
              home_unit = hsc_home_unit hsc_env
209
210
211
212
        ; let deps = mkDependencies home_unit
                                    (tcg_mod tcg_env)
                                    (tcg_imports tcg_env)
                                    (map mi_module pluginModules)
Simon Marlow's avatar
Simon Marlow committed
213

214
        ; used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
215
        ; dep_files <- readIORef dependent_files
216
        ; safe_mode <- finalSafeMode dflags tcg_env
217
        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env)
Matthew Pickering's avatar
Matthew Pickering committed
218

219
220
221
222
223
        ; let uc = initUsageConfig hsc_env
        ; let plugins = hsc_plugins hsc_env
        ; let fc = hsc_FC hsc_env
        ; let unit_env = hsc_unit_env hsc_env
        ; usages <- mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names
224
                      dep_files merged needed_mods needed_pkgs
Edward Z. Yang's avatar
Edward Z. Yang committed
225
226
        -- id_mod /= mod when we are processing an hsig, but hsigs
        -- never desugared and compiled (there's no code!)
227
228
        -- Consequently, this should hold for any ModGuts that make
        -- past desugaring. See Note [Identity versus semantic module].
229
        ; massert (id_mod == mod)
230

231
        ; foreign_files <- readIORef th_foreign_files_var
232

233
        ; docs <- extractDocs dflags tcg_env
234

235
        ; let mod_guts = ModGuts {
236
                mg_module       = mod,
237
                mg_hsc_src      = hsc_src,
238
                mg_loc          = mkFileSrcSpan mod_loc,
239
                mg_exports      = exports,
240
                mg_usages       = usages,
241
                mg_deps         = deps,
242
                mg_used_th      = used_th,
243
244
245
246
247
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
                mg_anns         = anns,
                mg_tcs          = tcs,
248
                mg_insts        = fixSafeInstances safe_mode insts,
249
250
251
                mg_fam_insts    = fam_insts,
                mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
Andreas Klebinger's avatar
Andreas Klebinger committed
252
                mg_boot_exports = bootExports self_boot,
253
                mg_patsyns      = patsyns,
254
255
                mg_rules        = ds_rules_for_imps,
                mg_binds        = ds_binds,
256
257
                mg_foreign      = ds_fords,
                mg_foreign_files = foreign_files,
258
                mg_hpc_info     = ds_hpc_info,
259
                mg_modBreaks    = modBreaks,
260
                mg_safe_haskell = safe_mode,
261
                mg_trust_pkg    = imp_trust_own_pkg imports,
262
                mg_complete_matches = complete_matches,
263
                mg_docs         = docs
264
              }
265
        ; return (msgs, Just mod_guts)
266
        }}}}
267

268
269
270
271
272
273
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
  = case ml_hs_file mod_loc of
      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
      Nothing        -> interactiveSrcSpan   -- Presumably

274
275
276
277
278
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) }
279

batterseapower's avatar
batterseapower committed
280
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
281
282
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
283
combineEvBinds [] val_prs
284
  = [Rec val_prs]
batterseapower's avatar
batterseapower committed
285
combineEvBinds (NonRec b r : bs) val_prs
286
287
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
288
combineEvBinds (Rec prs : bs) val_prs
289
290
  = combineEvBinds bs (prs ++ val_prs)

Austin Seipp's avatar
Austin Seipp committed
291
{-
292
293
294
295
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
296
because the occurrence analyser doesn't take account of type/coercion variables
297
when computing dependencies.
298
299
300

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

303
deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
Sylvain Henry's avatar
Sylvain Henry committed
304
305
deSugarExpr hsc_env tc_expr = do
    let logger = hsc_logger hsc_env
306

307
    showPass logger "Desugar"
308

Sylvain Henry's avatar
Sylvain Henry committed
309
    -- Do desugaring
310
311
312
313
    (tc_msgs, mb_result) <- runTcInteractive hsc_env $
                            initDsTc $
                            dsLExpr tc_expr

314
    massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here
315
316
317
318

      -- mb_result is Nothing only when a failure happens in the type-checker,
      -- but mb_core_expr is Nothing when a failure happens in the desugarer
    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result
319

Sylvain Henry's avatar
Sylvain Henry committed
320
321
    case mb_core_expr of
       Nothing   -> return ()
322
       Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared"
Sylvain Henry's avatar
Sylvain Henry committed
323
                    FormatCore (pprCoreExpr expr)
324

325
326
327
328
329
330
      -- callers (i.e. ioMsgMaybe) expect that no expression is returned if
      -- there are errors
    let final_res | errorsFound ds_msgs = Nothing
                  | otherwise           = mb_core_expr

    return (ds_msgs, final_res)
331

Austin Seipp's avatar
Austin Seipp committed
332
333
334
335
336
337
338
{-
************************************************************************
*                                                                      *
*              Add rules and export flags to binders
*                                                                      *
************************************************************************
-}
339

340
addExportFlagsAndRules
Sylvain Henry's avatar
Sylvain Henry committed
341
    :: Backend -> NameSet -> NameSet -> [CoreRule]
342
    -> [(Id, t)] -> [(Id, t)]
Sylvain Henry's avatar
Sylvain Henry committed
343
addExportFlagsAndRules bcknd exports keep_alive rules prs
344
  = mapFst add_one prs
345
  where
346
347
348
349
350
    add_one bndr = add_rules name (add_export name bndr)
       where
         name = idName bndr

    ---------- Rules --------
351
352
353
        -- See Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas
354
    add_rules name bndr
355
356
357
358
        | Just rules <- lookupNameEnv rule_base name
        = bndr `addIdSpecialisations` rules
        | otherwise
        = bndr
359
360
361
362
363
    rule_base = extendRuleBaseList emptyRuleBase rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    add_export name bndr
364
365
        | dont_discard name = setIdExported bndr
        | otherwise         = bndr
366

367
368
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
369
370
371
372
373
374
375
376
377
                     || 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.
378
    is_exported :: Name -> Bool
379
    is_exported | backendWantsGlobalBindings bcknd = isExternalName
380
                | otherwise                       = (`elemNameSet` exports)
sof's avatar
sof committed
381

Austin Seipp's avatar
Austin Seipp committed
382
{-
383
384
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
385
386
387
388
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
389
390

It means that the binding won't be discarded EVEN if the binding
391
ends up being trivial (v = w) -- the simplifier would usually just
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
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
407
  - It means that rewrite rules and specialisations for
408
409
410
411
412
413
414
415
416
417
    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

418

Austin Seipp's avatar
Austin Seipp committed
419
420
************************************************************************
*                                                                      *
421
*              Desugaring rewrite rules
Austin Seipp's avatar
Austin Seipp committed
422
423
424
*                                                                      *
************************************************************************
-}
425

426
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
427
428
429
430
431
dsRule (L loc (HsRule { rd_name = name
                      , rd_act  = rule_act
                      , rd_tmvs = vars
                      , rd_lhs  = lhs
                      , rd_rhs  = rhs }))
Alan Zimmerman's avatar
Alan Zimmerman committed
432
  = putSrcSpanDs (locA loc) $
433
    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
434

ian@well-typed.com's avatar
ian@well-typed.com committed
435
        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
436
                  unsetWOptM Opt_WarnIdentities $
437
                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
438

439
        ; rhs' <- dsLExpr rhs
440
        ; this_mod <- getModule
441

442
443
        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

444
445
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
446
447
        ; dflags <- getDynFlags
        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
448
                Left msg -> do { diagnosticDs msg; return Nothing } ;
449
450
                Right (final_bndrs, fn_id, args) -> do

451
        { let is_local = isLocalId fn_id
452
453
454
455
                -- 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
456
              simpl_opts = initSimpleOpts dflags
457
              final_rhs = simpleOptExpr simpl_opts rhs''    -- De-crap it
458
              rule_name = snd (unLoc name)
niteria's avatar
niteria committed
459
460
461
              final_bndrs_set = mkVarSet final_bndrs
              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
                        exprsSomeFreeVarsList isId args
462

463
464
465
        ; rule <- dsMkUserRule this_mod is_local
                         rule_name rule_act fn_name final_bndrs args
                         final_rhs
466
        ; warnRuleShadowing rule_name rule_act fn_id arg_ids
467

468
469
470
471
472
473
474
475
476
477
478
479
480
        ; 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)
481
                       -- If imported with no unfolding, no worries
482
      , idInlineActivation lhs_id `competesWith` rule_act
483
      = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act)
484
485
      | check_rules_too
      , bad_rule : _ <- get_bad_rules lhs_id
486
      = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id)
487
488
489
490
491
492
      | otherwise
      = return ()

    get_bad_rules lhs_id
      = [ rule | rule <- idCoreRules lhs_id
               , ruleActivation rule `competesWith` rule_act ]
493
494
495
496
497
498
499
500
501
502

-- 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)
503
504
505
506
507
508
509
510
511
512
        | 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')
513
514

            (bndrs, wrap) <- go vs
515
            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
516
517
518
519
        | otherwise = do
            (bndrs,wrap) <- go vs
            return (v:bndrs, wrap)

520
521
{- Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522
523
524
525
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
526
switching off EnableRewriteRules.  See GHC.HsToCore.Expr.dsExplicitList.
527
528

That keeps the desugaring of list comprehensions simple too.
529

530
Nor do we want to warn of conversion identities on the LHS;
531
the rule is precisely to optimise them:
532
  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
533

534
535
536
537
538
539
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
540
as a RULE, and this optimizes any kind of mapped' casts away, including `map
541
542
543
544
545
546
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).
Sylvain Henry's avatar
Sylvain Henry committed
547
See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.
548

549
550
551
552
553
554
555
556
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)...
557
then 'f' or 'g' will inline before the rule can fire.  Solution: add an
558
559
560
561
562
563
564
565
566
567
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
568
active; or perhaps after "rule-for-g" has become inactive. This is checked
569
570
571
572
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
573
match on class methods in RULE lhs's.   See #10595.   I'm not happy
Gabor Greif's avatar
Gabor Greif committed
574
about this. For example in Control.Arrow we have
575
576
577
578
579
580

{-# 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
581
class method rules inactive in phase 2, but that would delay when
582
subsequent transformations could fire.
Austin Seipp's avatar
Austin Seipp committed
583
-}
584
585
586
587
588
589
590
591
592
593
594

{-
************************************************************************
*                                                                      *
*              Magic definitions
*                                                                      *
************************************************************************

Note [Patching magic definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We sometimes need to have access to defined Ids in pure contexts. Usually, we
Sylvain Henry's avatar
Sylvain Henry committed
595
simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids
Sylvain Henry's avatar
Sylvain Henry committed
596
in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make.
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662

However, it is sometimes *much* easier to define entities in Haskell,
even if we need pure access; note that wiring-in an Id requires all
entities used in its definition *also* to be wired in, transitively
and recursively.  This can be a huge pain.  The little trick
documented here allows us to have the best of both worlds.

Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the
details.

The trick is to

* Define the known-key Id in a library module, with a stub definition,
     unsafeCoerce# :: ..a suitable type signature..
     unsafeCoerce# = error "urk"

* Magically over-write its RHS here in the desugarer, in
  patchMagicDefns.  This update can be done with full access to the
  DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in
  all the entities used internally, a potentially big win.

  This step should not change the Name or type of the Id.

Because an Id stores its unfolding directly (as opposed to in the second
component of a (Id, CoreExpr) pair), the patchMagicDefns function returns
a new Id to use.

Here are the moving parts:

- patchMagicDefns checks whether we're in a module with magic definitions;
  if so, patch the magic definitions. If not, skip.

- patchMagicDefn just looks up in an environment to find a magic defn and
  patches it in.

- magicDefns holds the magic definitions.

- magicDefnsEnv allows for quick access to magicDefns.

- magicDefnModules, built also from magicDefns, contains the modules that
  need careful attention.

Note [Wiring in unsafeCoerce#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want (Haskell)

  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                          (a :: TYPE r1) (b :: TYPE r2).
                   a -> b
  unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of
    UnsafeRefl -> case unsafeEqualityProof @a @b of
      UnsafeRefl -> x

or (Core)

  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                          (a :: TYPE r1) (b :: TYPE r2).
                   a -> b
  unsafeCoerce# = \ @r1 @r2 @a @b (x :: a).
    case unsafeEqualityProof @RuntimeRep @r1 @r2 of
      UnsafeRefl (co1 :: r1 ~# r2) ->
        case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of
          UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) ->
            (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)

It looks like we can write this in Haskell directly, but we can't:
663
the representation polymorphism checks defeat us. Note that `x` is a
664
665
representation-polymorphic variable. So we must wire it in with a
compulsory unfolding, like other representation-polymorphic primops.
666
667
668
669
670
671
672
673
674

The challenge is that UnsafeEquality is a GADT, and wiring in a GADT
is *hard*: it has a worker separate from its wrapper, with all manner
of complications. (Simon and Richard tried to do this. We nearly wept.)

The solution is documented in Note [Patching magic definitions]. We now
simply look up the UnsafeEquality GADT in the environment, leaving us
only to wire in unsafeCoerce# directly.

675
Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
-}


-- Postcondition: the returned Ids are in one-to-one correspondence as the
-- input Ids; each returned Id has the same type as the passed-in Id.
-- See Note [Patching magic definitions]
patchMagicDefns :: OrdList (Id,CoreExpr)
                -> DsM (OrdList (Id,CoreExpr))
patchMagicDefns pairs
  -- optimization: check whether we're in a magic module before looking
  -- at all the ids
  = do { this_mod <- getModule
       ; if this_mod `elemModuleSet` magicDefnModules
         then traverse patchMagicDefn pairs
         else return pairs }

patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr)
patchMagicDefn orig_pair@(orig_id, orig_rhs)
  | Just mk_magic_pair <- lookupNameEnv magicDefnsEnv (getName orig_id)
  = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs

       -- Patching should not change the Name or the type of the Id
698
699
       ; massert (getUnique magic_id == getUnique orig_id)
       ; massert (varType magic_id `eqType` varType orig_id)
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727

       ; return magic_pair }
  | otherwise
  = return orig_pair

magicDefns :: [(Name,    Id -> CoreExpr     -- old Id and RHS
                      -> DsM (Id, CoreExpr) -- new Id and RHS
               )]
magicDefns = [ (unsafeCoercePrimName, mkUnsafeCoercePrimPair) ]

magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr))
magicDefnsEnv = mkNameEnv magicDefns

magicDefnModules :: ModuleSet
magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns

mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr)
-- See Note [Wiring in unsafeCoerce#] for the defn we are creating here
mkUnsafeCoercePrimPair _old_id old_expr
  = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName
       ; unsafe_equality_tc       <- dsLookupTyCon unsafeEqualityTyConName

       ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc

             rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
                          , openAlphaTyVar, openBetaTyVar
                          , x ] $
                   mkSingleAltCase scrut1
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
728
                                   (mkWildValBinder Many scrut1_ty)
729
730
731
                                   (DataAlt unsafe_refl_data_con)
                                   [rr_cv] $
                   mkSingleAltCase scrut2
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
732
                                   (mkWildValBinder Many scrut2_ty)
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
                                   (DataAlt unsafe_refl_data_con)
                                   [ab_cv] $
                   Var x `mkCast` x_co

             [x, rr_cv, ab_cv] = mkTemplateLocals
               [ openAlphaTy -- x :: a
               , rr_cv_ty    -- rr_cv :: r1 ~# r2
               , ab_cv_ty    -- ab_cv :: (alpha |> alpha_co ~# beta)
               ]

             -- Returns (scrutinee, scrutinee type, type of covar in AltCon)
             unsafe_equality k a b
               = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a]
                 , mkTyConApp unsafe_equality_tc [k,b,a]
                 , mkHeteroPrimEqPred k k a b
                 )
             -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to
             -- carefully swap the arguments above

             (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy
                                                             runtimeRep1Ty
                                                             runtimeRep2Ty
Ben Gamari's avatar
Ben Gamari committed
755
             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)
756
757
758
759
760
761
762
763
764
765
766
767
768
                                                             (openAlphaTy `mkCastTy` alpha_co)
                                                             openBetaTy

             -- alpha_co :: TYPE r1 ~# TYPE r2
             -- alpha_co = TYPE rr_cv
             alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv]

             -- x_co :: alpha ~R# beta
             x_co = mkGReflCo Representational openAlphaTy (MCo alpha_co) `mkTransCo`
                    mkSubCo (mkCoVarCo ab_cv)


             info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
769
                                `setUnfoldingInfo` mkCompulsoryUnfolding' rhs
770
                                `setArityInfo`     arity
771
772
773

             ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
                                  , openAlphaTyVar, openBetaTyVar ] $
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
774
                  mkVisFunTyMany openAlphaTy openBetaTy
775

776
777
             arity = 1

778
779
             id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info
       ; return (id, old_expr) }