never executed always true always false
1
2 {-# LANGUAGE TypeFamilies #-}
3
4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
5
6 {-
7 (c) The University of Glasgow 2006
8 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
9
10
11 The Desugarer: turning HsSyn into Core.
12 -}
13
14 module GHC.HsToCore (
15 -- * Desugaring operations
16 deSugar, deSugarExpr
17 ) where
18
19 import GHC.Prelude
20
21 import GHC.Driver.Session
22 import GHC.Driver.Config
23 import GHC.Driver.Env
24 import GHC.Driver.Backend
25
26 import GHC.Hs
27
28 import GHC.HsToCore.Usage
29 import GHC.HsToCore.Monad
30 import GHC.HsToCore.Errors.Types
31 import GHC.HsToCore.Expr
32 import GHC.HsToCore.Binds
33 import GHC.HsToCore.Foreign.Decl
34 import GHC.HsToCore.Coverage
35 import GHC.HsToCore.Docs
36
37 import GHC.Tc.Types
38 import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances )
39 import GHC.Tc.Module ( runTcInteractive )
40
41 import GHC.Core.Type
42 import GHC.Core.TyCon ( tyConDataCons )
43 import GHC.Core
44 import GHC.Core.FVs ( exprsSomeFreeVarsList )
45 import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
46 import GHC.Core.Utils
47 import GHC.Core.Unfold.Make
48 import GHC.Core.Coercion
49 import GHC.Core.DataCon ( dataConWrapId )
50 import GHC.Core.Make
51 import GHC.Core.Rules
52 import GHC.Core.Opt.Monad ( CoreToDo(..) )
53 import GHC.Core.Lint ( endPassIO )
54 import GHC.Core.Ppr
55
56 import GHC.Builtin.Names
57 import GHC.Builtin.Types.Prim
58 import GHC.Builtin.Types
59
60 import GHC.Data.FastString
61 import GHC.Data.Maybe ( expectJust )
62 import GHC.Data.OrdList
63
64 import GHC.Utils.Error
65 import GHC.Utils.Outputable
66 import GHC.Utils.Panic.Plain
67 import GHC.Utils.Misc
68 import GHC.Utils.Monad
69 import GHC.Utils.Logger
70
71 import GHC.Types.Id
72 import GHC.Types.Id.Info
73 import GHC.Types.ForeignStubs
74 import GHC.Types.Avail
75 import GHC.Types.Basic
76 import GHC.Types.Var.Set
77 import GHC.Types.SrcLoc
78 import GHC.Types.SourceFile
79 import GHC.Types.TypeEnv
80 import GHC.Types.Name
81 import GHC.Types.Name.Set
82 import GHC.Types.Name.Env
83 import GHC.Types.Name.Ppr
84 import GHC.Types.HpcInfo
85
86 import GHC.Unit
87 import GHC.Unit.Module.ModGuts
88 import GHC.Unit.Module.ModIface
89 import GHC.Unit.Module.Deps
90
91 import Data.List (partition)
92 import Data.IORef
93 import GHC.Driver.Plugins ( LoadedPlugin(..) )
94
95 {-
96 ************************************************************************
97 * *
98 * The main function: deSugar
99 * *
100 ************************************************************************
101 -}
102
103 -- | Main entry point to the desugarer.
104 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
105 -- Can modify PCS by faulting in more declarations
106
107 deSugar hsc_env
108 mod_loc
109 tcg_env@(TcGblEnv { tcg_mod = id_mod,
110 tcg_semantic_mod = mod,
111 tcg_src = hsc_src,
112 tcg_type_env = type_env,
113 tcg_imports = imports,
114 tcg_exports = exports,
115 tcg_keep = keep_var,
116 tcg_th_splice_used = tc_splice_used,
117 tcg_rdr_env = rdr_env,
118 tcg_fix_env = fix_env,
119 tcg_inst_env = inst_env,
120 tcg_fam_inst_env = fam_inst_env,
121 tcg_merged = merged,
122 tcg_warns = warns,
123 tcg_anns = anns,
124 tcg_binds = binds,
125 tcg_imp_specs = imp_specs,
126 tcg_dependent_files = dependent_files,
127 tcg_ev_binds = ev_binds,
128 tcg_th_foreign_files = th_foreign_files_var,
129 tcg_fords = fords,
130 tcg_rules = rules,
131 tcg_patsyns = patsyns,
132 tcg_tcs = tcs,
133 tcg_insts = insts,
134 tcg_fam_insts = fam_insts,
135 tcg_hpc = other_hpc_info,
136 tcg_complete_matches = complete_matches
137 })
138
139 = do { let dflags = hsc_dflags hsc_env
140 logger = hsc_logger hsc_env
141 print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
142 ; withTiming logger
143 (text "Desugar"<+>brackets (ppr mod))
144 (const ()) $
145 do { -- Desugar the program
146 ; let export_set = availsToNameSet exports
147 bcknd = backend dflags
148 hpcInfo = emptyHpcInfo other_hpc_info
149
150 ; (binds_cvr, ds_hpc_info, modBreaks)
151 <- if not (isHsBootOrSig hsc_src)
152 then addTicksToBinds hsc_env mod mod_loc
153 export_set (typeEnvTyCons type_env) binds
154 else return (binds, hpcInfo, Nothing)
155 ; (msgs, mb_res) <- initDs hsc_env tcg_env $
156 do { ds_ev_binds <- dsEvBinds ev_binds
157 ; core_prs <- dsTopLHsBinds binds_cvr
158 ; core_prs <- patchMagicDefns core_prs
159 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
160 ; (ds_fords, foreign_prs) <- dsForeigns fords
161 ; ds_rules <- mapMaybeM dsRule rules
162 ; let hpc_init
163 | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info
164 | otherwise = mempty
165 ; return ( ds_ev_binds
166 , foreign_prs `appOL` core_prs `appOL` spec_prs
167 , spec_rules ++ ds_rules
168 , ds_fords `appendStubC` hpc_init) }
169
170 ; case mb_res of {
171 Nothing -> return (msgs, Nothing) ;
172 Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
173
174 do { -- Add export flags to bindings
175 keep_alive <- readIORef keep_var
176 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
177 final_prs = addExportFlagsAndRules bcknd export_set keep_alive
178 rules_for_locals (fromOL all_prs)
179
180 final_pgm = combineEvBinds ds_ev_binds final_prs
181 -- Notice that we put the whole lot in a big Rec, even the foreign binds
182 -- When compiling PrelFloat, which defines data Float = F# Float#
183 -- we want F# to be in scope in the foreign marshalling code!
184 -- You might think it doesn't matter, but the simplifier brings all top-level
185 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
186
187 ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
188 ; let simpl_opts = initSimpleOpts dflags
189 ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
190 = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
191 -- The simpleOptPgm gets rid of type
192 -- bindings plus any stupid dead code
193 ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
194 FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
195
196 ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
197
198 ; let used_names = mkUsedNames tcg_env
199 pluginModules = map lpModule (hsc_plugins hsc_env)
200 home_unit = hsc_home_unit hsc_env
201 ; let deps = mkDependencies home_unit
202 (tcg_mod tcg_env)
203 (tcg_imports tcg_env)
204 (map mi_module pluginModules)
205
206 ; used_th <- readIORef tc_splice_used
207 ; dep_files <- readIORef dependent_files
208 ; safe_mode <- finalSafeMode dflags tcg_env
209
210 ; usages <- mkUsageInfo hsc_env mod hsc_src (imp_mods imports) used_names
211 dep_files merged
212 -- id_mod /= mod when we are processing an hsig, but hsigs
213 -- never desugared and compiled (there's no code!)
214 -- Consequently, this should hold for any ModGuts that make
215 -- past desugaring. See Note [Identity versus semantic module].
216 ; massert (id_mod == mod)
217
218 ; foreign_files <- readIORef th_foreign_files_var
219
220 ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env
221
222 ; let mod_guts = ModGuts {
223 mg_module = mod,
224 mg_hsc_src = hsc_src,
225 mg_loc = mkFileSrcSpan mod_loc,
226 mg_exports = exports,
227 mg_usages = usages,
228 mg_deps = deps,
229 mg_used_th = used_th,
230 mg_rdr_env = rdr_env,
231 mg_fix_env = fix_env,
232 mg_warns = warns,
233 mg_anns = anns,
234 mg_tcs = tcs,
235 mg_insts = fixSafeInstances safe_mode insts,
236 mg_fam_insts = fam_insts,
237 mg_inst_env = inst_env,
238 mg_fam_inst_env = fam_inst_env,
239 mg_patsyns = patsyns,
240 mg_rules = ds_rules_for_imps,
241 mg_binds = ds_binds,
242 mg_foreign = ds_fords,
243 mg_foreign_files = foreign_files,
244 mg_hpc_info = ds_hpc_info,
245 mg_modBreaks = modBreaks,
246 mg_safe_haskell = safe_mode,
247 mg_trust_pkg = imp_trust_own_pkg imports,
248 mg_complete_matches = complete_matches,
249 mg_doc_hdr = doc_hdr,
250 mg_decl_docs = decl_docs,
251 mg_arg_docs = arg_docs
252 }
253 ; return (msgs, Just mod_guts)
254 }}}}
255
256 mkFileSrcSpan :: ModLocation -> SrcSpan
257 mkFileSrcSpan mod_loc
258 = case ml_hs_file mod_loc of
259 Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
260 Nothing -> interactiveSrcSpan -- Presumably
261
262 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
263 dsImpSpecs imp_specs
264 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
265 ; let (spec_binds, spec_rules) = unzip spec_prs
266 ; return (concatOL spec_binds, spec_rules) }
267
268 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
269 -- Top-level bindings can include coercion bindings, but not via superclasses
270 -- See Note [Top-level evidence]
271 combineEvBinds [] val_prs
272 = [Rec val_prs]
273 combineEvBinds (NonRec b r : bs) val_prs
274 | isId b = combineEvBinds bs ((b,r):val_prs)
275 | otherwise = NonRec b r : combineEvBinds bs val_prs
276 combineEvBinds (Rec prs : bs) val_prs
277 = combineEvBinds bs (prs ++ val_prs)
278
279 {-
280 Note [Top-level evidence]
281 ~~~~~~~~~~~~~~~~~~~~~~~~~
282 Top-level evidence bindings may be mutually recursive with the top-level value
283 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
284 because the occurrence analyser doesn't take account of type/coercion variables
285 when computing dependencies.
286
287 So we pull out the type/coercion variables (which are in dependency order),
288 and Rec the rest.
289 -}
290
291 deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
292 deSugarExpr hsc_env tc_expr = do
293 let logger = hsc_logger hsc_env
294
295 showPass logger "Desugar"
296
297 -- Do desugaring
298 (tc_msgs, mb_result) <- runTcInteractive hsc_env $
299 initDsTc $
300 dsLExpr tc_expr
301
302 massert (isEmptyMessages tc_msgs) -- the type-checker isn't doing anything here
303
304 -- mb_result is Nothing only when a failure happens in the type-checker,
305 -- but mb_core_expr is Nothing when a failure happens in the desugarer
306 let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result
307
308 case mb_core_expr of
309 Nothing -> return ()
310 Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared"
311 FormatCore (pprCoreExpr expr)
312
313 -- callers (i.e. ioMsgMaybe) expect that no expression is returned if
314 -- there are errors
315 let final_res | errorsFound ds_msgs = Nothing
316 | otherwise = mb_core_expr
317
318 return (ds_msgs, final_res)
319
320 {-
321 ************************************************************************
322 * *
323 * Add rules and export flags to binders
324 * *
325 ************************************************************************
326 -}
327
328 addExportFlagsAndRules
329 :: Backend -> NameSet -> NameSet -> [CoreRule]
330 -> [(Id, t)] -> [(Id, t)]
331 addExportFlagsAndRules bcknd exports keep_alive rules prs
332 = mapFst add_one prs
333 where
334 add_one bndr = add_rules name (add_export name bndr)
335 where
336 name = idName bndr
337
338 ---------- Rules --------
339 -- See Note [Attach rules to local ids]
340 -- NB: the binder might have some existing rules,
341 -- arising from specialisation pragmas
342 add_rules name bndr
343 | Just rules <- lookupNameEnv rule_base name
344 = bndr `addIdSpecialisations` rules
345 | otherwise
346 = bndr
347 rule_base = extendRuleBaseList emptyRuleBase rules
348
349 ---------- Export flag --------
350 -- See Note [Adding export flags]
351 add_export name bndr
352 | dont_discard name = setIdExported bndr
353 | otherwise = bndr
354
355 dont_discard :: Name -> Bool
356 dont_discard name = is_exported name
357 || name `elemNameSet` keep_alive
358
359 -- In interactive mode, we don't want to discard any top-level
360 -- entities at all (eg. do not inline them away during
361 -- simplification), and retain them all in the TypeEnv so they are
362 -- available from the command line.
363 --
364 -- isExternalName separates the user-defined top-level names from those
365 -- introduced by the type checker.
366 is_exported :: Name -> Bool
367 is_exported | backendRetainsAllBindings bcknd = isExternalName
368 | otherwise = (`elemNameSet` exports)
369
370 {-
371 Note [Adding export flags]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~
373 Set the no-discard flag if either
374 a) the Id is exported
375 b) it's mentioned in the RHS of an orphan rule
376 c) it's in the keep-alive set
377
378 It means that the binding won't be discarded EVEN if the binding
379 ends up being trivial (v = w) -- the simplifier would usually just
380 substitute w for v throughout, but we don't apply the substitution to
381 the rules (maybe we should?), so this substitution would make the rule
382 bogus.
383
384 You might wonder why exported Ids aren't already marked as such;
385 it's just because the type checker is rather busy already and
386 I didn't want to pass in yet another mapping.
387
388 Note [Attach rules to local ids]
389 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
390 Find the rules for locally-defined Ids; then we can attach them
391 to the binders in the top-level bindings
392
393 Reason
394 - It makes the rules easier to look up
395 - It means that rewrite rules and specialisations for
396 locally defined Ids are handled uniformly
397 - It keeps alive things that are referred to only from a rule
398 (the occurrence analyser knows about rules attached to Ids)
399 - It makes sure that, when we apply a rule, the free vars
400 of the RHS are more likely to be in scope
401 - The imported rules are carried in the in-scope set
402 which is extended on each iteration by the new wave of
403 local binders; any rules which aren't on the binding will
404 thereby get dropped
405
406
407 ************************************************************************
408 * *
409 * Desugaring rewrite rules
410 * *
411 ************************************************************************
412 -}
413
414 dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
415 dsRule (L loc (HsRule { rd_name = name
416 , rd_act = rule_act
417 , rd_tmvs = vars
418 , rd_lhs = lhs
419 , rd_rhs = rhs }))
420 = putSrcSpanDs (locA loc) $
421 do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
422
423 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
424 unsetWOptM Opt_WarnIdentities $
425 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
426
427 ; rhs' <- dsLExpr rhs
428 ; this_mod <- getModule
429
430 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
431
432 -- Substitute the dict bindings eagerly,
433 -- and take the body apart into a (f args) form
434 ; dflags <- getDynFlags
435 ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
436 Left msg -> do { diagnosticDs msg; return Nothing } ;
437 Right (final_bndrs, fn_id, args) -> do
438
439 { let is_local = isLocalId fn_id
440 -- NB: isLocalId is False of implicit Ids. This is good because
441 -- we don't want to attach rules to the bindings of implicit Ids,
442 -- because they don't show up in the bindings until just before code gen
443 fn_name = idName fn_id
444 simpl_opts = initSimpleOpts dflags
445 final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it
446 rule_name = snd (unLoc name)
447 final_bndrs_set = mkVarSet final_bndrs
448 arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
449 exprsSomeFreeVarsList isId args
450
451 ; rule <- dsMkUserRule this_mod is_local
452 rule_name rule_act fn_name final_bndrs args
453 final_rhs
454 ; warnRuleShadowing rule_name rule_act fn_id arg_ids
455
456 ; return (Just rule)
457 } } }
458
459 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
460 -- See Note [Rules and inlining/other rules]
461 warnRuleShadowing rule_name rule_act fn_id arg_ids
462 = do { check False fn_id -- We often have multiple rules for the same Id in a
463 -- module. Maybe we should check that they don't overlap
464 -- but currently we don't
465 ; mapM_ (check True) arg_ids }
466 where
467 check check_rules_too lhs_id
468 | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
469 -- If imported with no unfolding, no worries
470 , idInlineActivation lhs_id `competesWith` rule_act
471 = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act)
472 | check_rules_too
473 , bad_rule : _ <- get_bad_rules lhs_id
474 = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id)
475 | otherwise
476 = return ()
477
478 get_bad_rules lhs_id
479 = [ rule | rule <- idCoreRules lhs_id
480 , ruleActivation rule `competesWith` rule_act ]
481
482 -- See Note [Desugaring coerce as cast]
483 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
484 unfold_coerce bndrs lhs rhs = do
485 (bndrs', wrap) <- go bndrs
486 return (bndrs', wrap lhs, wrap rhs)
487 where
488 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
489 go [] = return ([], id)
490 go (v:vs)
491 | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
492 , tc `hasKey` coercibleTyConKey = do
493 u <- newUnique
494
495 let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
496 v' = mkLocalCoVar
497 (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
498 box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
499 [k, t1, t2] `App`
500 Coercion (mkCoVarCo v')
501
502 (bndrs, wrap) <- go vs
503 return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
504 | otherwise = do
505 (bndrs,wrap) <- go vs
506 return (v:bndrs, wrap)
507
508 {- Note [Desugaring RULE left hand sides]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 For the LHS of a RULE we do *not* want to desugar
511 [x] to build (\cn. x `c` n)
512 We want to leave explicit lists simply as chains
513 of cons's. We can achieve that slightly indirectly by
514 switching off EnableRewriteRules. See GHC.HsToCore.Expr.dsExplicitList.
515
516 That keeps the desugaring of list comprehensions simple too.
517
518 Nor do we want to warn of conversion identities on the LHS;
519 the rule is precisely to optimise them:
520 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
521
522 Note [Desugaring coerce as cast]
523 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
524 We want the user to express a rule saying roughly “mapping a coercion over a
525 list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
526 be written in Haskell. So we use `coerce` for that (#2110). The user writes
527 map coerce = coerce
528 as a RULE, and this optimizes any kind of mapped' casts away, including `map
529 MkNewtype`.
530
531 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
532 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
533 `let c = MkCoercible co in ...`. This is later simplified to the desired form
534 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
535 See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.
536
537 Note [Rules and inlining/other rules]
538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
539 If you have
540 f x = ...
541 g x = ...
542 {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
543 then there's a good chance that in a potential rule redex
544 ...f (g e)...
545 then 'f' or 'g' will inline before the rule can fire. Solution: add an
546 INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
547
548 Note that this applies to all the free variables on the LHS, both the
549 main function and things in its arguments.
550
551 We also check if there are Ids on the LHS that have competing RULES.
552 In the above example, suppose we had
553 {-# RULES "rule-for-g" forally. g [y] = ... #-}
554 Then "rule-for-f" and "rule-for-g" would compete. Better to add phase
555 control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
556 active; or perhaps after "rule-for-g" has become inactive. This is checked
557 by 'competesWith'
558
559 Class methods have a built-in RULE to select the method from the dictionary,
560 so you can't change the phase on this. That makes id very dubious to
561 match on class methods in RULE lhs's. See #10595. I'm not happy
562 about this. For example in Control.Arrow we have
563
564 {-# RULES "compose/arr" forall f g .
565 (arr f) . (arr g) = arr (f . g) #-}
566
567 and similar, which will elicit exactly these warnings, and risk never
568 firing. But it's not clear what to do instead. We could make the
569 class method rules inactive in phase 2, but that would delay when
570 subsequent transformations could fire.
571 -}
572
573 {-
574 ************************************************************************
575 * *
576 * Magic definitions
577 * *
578 ************************************************************************
579
580 Note [Patching magic definitions]
581 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
582 We sometimes need to have access to defined Ids in pure contexts. Usually, we
583 simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids
584 in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make.
585
586 However, it is sometimes *much* easier to define entities in Haskell,
587 even if we need pure access; note that wiring-in an Id requires all
588 entities used in its definition *also* to be wired in, transitively
589 and recursively. This can be a huge pain. The little trick
590 documented here allows us to have the best of both worlds.
591
592 Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the
593 details.
594
595 The trick is to
596
597 * Define the known-key Id in a library module, with a stub definition,
598 unsafeCoerce# :: ..a suitable type signature..
599 unsafeCoerce# = error "urk"
600
601 * Magically over-write its RHS here in the desugarer, in
602 patchMagicDefns. This update can be done with full access to the
603 DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in
604 all the entities used internally, a potentially big win.
605
606 This step should not change the Name or type of the Id.
607
608 Because an Id stores its unfolding directly (as opposed to in the second
609 component of a (Id, CoreExpr) pair), the patchMagicDefns function returns
610 a new Id to use.
611
612 Here are the moving parts:
613
614 - patchMagicDefns checks whether we're in a module with magic definitions;
615 if so, patch the magic definitions. If not, skip.
616
617 - patchMagicDefn just looks up in an environment to find a magic defn and
618 patches it in.
619
620 - magicDefns holds the magic definitions.
621
622 - magicDefnsEnv allows for quick access to magicDefns.
623
624 - magicDefnModules, built also from magicDefns, contains the modules that
625 need careful attention.
626
627 Note [Wiring in unsafeCoerce#]
628 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
629 We want (Haskell)
630
631 unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
632 (a :: TYPE r1) (b :: TYPE r2).
633 a -> b
634 unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of
635 UnsafeRefl -> case unsafeEqualityProof @a @b of
636 UnsafeRefl -> x
637
638 or (Core)
639
640 unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
641 (a :: TYPE r1) (b :: TYPE r2).
642 a -> b
643 unsafeCoerce# = \ @r1 @r2 @a @b (x :: a).
644 case unsafeEqualityProof @RuntimeRep @r1 @r2 of
645 UnsafeRefl (co1 :: r1 ~# r2) ->
646 case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of
647 UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) ->
648 (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)
649
650 It looks like we can write this in Haskell directly, but we can't:
651 the representation polymorphism checks defeat us. Note that `x` is a
652 representation-polymorphic variable. So we must wire it in with a
653 compulsory unfolding, like other representation-polymorphic primops.
654
655 The challenge is that UnsafeEquality is a GADT, and wiring in a GADT
656 is *hard*: it has a worker separate from its wrapper, with all manner
657 of complications. (Simon and Richard tried to do this. We nearly wept.)
658
659 The solution is documented in Note [Patching magic definitions]. We now
660 simply look up the UnsafeEquality GADT in the environment, leaving us
661 only to wire in unsafeCoerce# directly.
662
663 Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
664 -}
665
666
667 -- Postcondition: the returned Ids are in one-to-one correspondence as the
668 -- input Ids; each returned Id has the same type as the passed-in Id.
669 -- See Note [Patching magic definitions]
670 patchMagicDefns :: OrdList (Id,CoreExpr)
671 -> DsM (OrdList (Id,CoreExpr))
672 patchMagicDefns pairs
673 -- optimization: check whether we're in a magic module before looking
674 -- at all the ids
675 = do { this_mod <- getModule
676 ; if this_mod `elemModuleSet` magicDefnModules
677 then traverse patchMagicDefn pairs
678 else return pairs }
679
680 patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr)
681 patchMagicDefn orig_pair@(orig_id, orig_rhs)
682 | Just mk_magic_pair <- lookupNameEnv magicDefnsEnv (getName orig_id)
683 = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs
684
685 -- Patching should not change the Name or the type of the Id
686 ; massert (getUnique magic_id == getUnique orig_id)
687 ; massert (varType magic_id `eqType` varType orig_id)
688
689 ; return magic_pair }
690 | otherwise
691 = return orig_pair
692
693 magicDefns :: [(Name, Id -> CoreExpr -- old Id and RHS
694 -> DsM (Id, CoreExpr) -- new Id and RHS
695 )]
696 magicDefns = [ (unsafeCoercePrimName, mkUnsafeCoercePrimPair) ]
697
698 magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr))
699 magicDefnsEnv = mkNameEnv magicDefns
700
701 magicDefnModules :: ModuleSet
702 magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns
703
704 mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr)
705 -- See Note [Wiring in unsafeCoerce#] for the defn we are creating here
706 mkUnsafeCoercePrimPair _old_id old_expr
707 = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName
708 ; unsafe_equality_tc <- dsLookupTyCon unsafeEqualityTyConName
709
710 ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc
711
712 rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
713 , openAlphaTyVar, openBetaTyVar
714 , x ] $
715 mkSingleAltCase scrut1
716 (mkWildValBinder Many scrut1_ty)
717 (DataAlt unsafe_refl_data_con)
718 [rr_cv] $
719 mkSingleAltCase scrut2
720 (mkWildValBinder Many scrut2_ty)
721 (DataAlt unsafe_refl_data_con)
722 [ab_cv] $
723 Var x `mkCast` x_co
724
725 [x, rr_cv, ab_cv] = mkTemplateLocals
726 [ openAlphaTy -- x :: a
727 , rr_cv_ty -- rr_cv :: r1 ~# r2
728 , ab_cv_ty -- ab_cv :: (alpha |> alpha_co ~# beta)
729 ]
730
731 -- Returns (scrutinee, scrutinee type, type of covar in AltCon)
732 unsafe_equality k a b
733 = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a]
734 , mkTyConApp unsafe_equality_tc [k,b,a]
735 , mkHeteroPrimEqPred k k a b
736 )
737 -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to
738 -- carefully swap the arguments above
739
740 (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy
741 runtimeRep1Ty
742 runtimeRep2Ty
743 (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty)
744 (openAlphaTy `mkCastTy` alpha_co)
745 openBetaTy
746
747 -- alpha_co :: TYPE r1 ~# TYPE r2
748 -- alpha_co = TYPE rr_cv
749 alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv]
750
751 -- x_co :: alpha ~R# beta
752 x_co = mkGReflCo Representational openAlphaTy (MCo alpha_co) `mkTransCo`
753 mkSubCo (mkCoVarCo ab_cv)
754
755
756 info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
757 `setUnfoldingInfo` mkCompulsoryUnfolding' rhs
758 `setArityInfo` arity
759
760 ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
761 , openAlphaTyVar, openBetaTyVar ] $
762 mkVisFunTyMany openAlphaTy openBetaTy
763
764 arity = 1
765
766 id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info
767 ; return (id, old_expr) }