Implement -XStaticValues
[ghc.git] / compiler / deSugar / Desugar.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 The Desugarer: turning HsSyn into Core.
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module Desugar ( deSugar, deSugarExpr ) where
12
13 import DynFlags
14 import HscTypes
15 import HsSyn
16 import TcRnTypes
17 import TcRnMonad ( finalSafeMode )
18 import MkIface
19 import Id
20 import Name
21 import Type
22 import FamInstEnv
23 import Coercion
24 import InstEnv
25 import Class
26 import Avail
27 import PatSyn
28 import CoreSyn
29 import CoreSubst
30 import PprCore
31 import DsMonad
32 import DsExpr
33 import DsBinds
34 import DsForeign
35 import Module
36 import NameSet
37 import NameEnv
38 import Rules
39 import TysPrim (eqReprPrimTyCon)
40 import TysWiredIn (coercibleTyCon )
41 import BasicTypes ( Activation(.. ) )
42 import CoreMonad ( endPassIO, CoreToDo(..) )
43 import MkCore
44 import FastString
45 import ErrUtils
46 import Outputable
47 import SrcLoc
48 import Coverage
49 import Util
50 import MonadUtils
51 import OrdList
52 import StaticPtrTable
53 import Data.List
54 import Data.IORef
55 import Control.Monad( when )
56
57 {-
58 ************************************************************************
59 * *
60 * The main function: deSugar
61 * *
62 ************************************************************************
63 -}
64
65 -- | Main entry point to the desugarer.
66 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
67 -- Can modify PCS by faulting in more declarations
68
69 deSugar hsc_env
70 mod_loc
71 tcg_env@(TcGblEnv { tcg_mod = mod,
72 tcg_src = hsc_src,
73 tcg_type_env = type_env,
74 tcg_imports = imports,
75 tcg_exports = exports,
76 tcg_keep = keep_var,
77 tcg_th_splice_used = tc_splice_used,
78 tcg_rdr_env = rdr_env,
79 tcg_fix_env = fix_env,
80 tcg_inst_env = inst_env,
81 tcg_fam_inst_env = fam_inst_env,
82 tcg_warns = warns,
83 tcg_anns = anns,
84 tcg_binds = binds,
85 tcg_imp_specs = imp_specs,
86 tcg_dependent_files = dependent_files,
87 tcg_ev_binds = ev_binds,
88 tcg_fords = fords,
89 tcg_rules = rules,
90 tcg_vects = vects,
91 tcg_patsyns = patsyns,
92 tcg_tcs = tcs,
93 tcg_insts = insts,
94 tcg_fam_insts = fam_insts,
95 tcg_hpc = other_hpc_info})
96
97 = do { let dflags = hsc_dflags hsc_env
98 print_unqual = mkPrintUnqualified dflags rdr_env
99 ; showPass dflags "Desugar"
100
101 -- Desugar the program
102 ; let export_set = availsToNameSet exports
103 target = hscTarget dflags
104 hpcInfo = emptyHpcInfo other_hpc_info
105 want_ticks = gopt Opt_Hpc dflags
106 || target == HscInterpreted
107 || (gopt Opt_SccProfilingOn dflags
108 && case profAuto dflags of
109 NoProfAuto -> False
110 _ -> True)
111
112 ; (binds_cvr, ds_hpc_info, modBreaks)
113 <- if want_ticks && not (isHsBootOrSig hsc_src)
114 then addTicksToBinds dflags mod mod_loc export_set
115 (typeEnvTyCons type_env) binds
116 else return (binds, hpcInfo, emptyModBreaks)
117
118 ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
119 do { ds_ev_binds <- dsEvBinds ev_binds
120 ; core_prs <- dsTopLHsBinds binds_cvr
121 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
122 ; (ds_fords, foreign_prs) <- dsForeigns fords
123 ; ds_rules <- mapMaybeM dsRule rules
124 ; ds_vects <- mapM dsVect vects
125 ; stBinds <- dsGetStaticBindsVar >>=
126 liftIO . readIORef
127 ; let hpc_init
128 | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
129 | otherwise = empty
130 -- Stub to insert the static entries of the
131 -- module into the static pointer table
132 spt_init = sptInitCode mod stBinds
133 ; return ( ds_ev_binds
134 , foreign_prs `appOL` core_prs `appOL` spec_prs
135 `appOL` toOL (map snd stBinds)
136 , spec_rules ++ ds_rules, ds_vects
137 , ds_fords `appendStubC` hpc_init
138 `appendStubC` spt_init) }
139
140 ; case mb_res of {
141 Nothing -> return (msgs, Nothing) ;
142 Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
143
144 do { -- Add export flags to bindings
145 keep_alive <- readIORef keep_var
146 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
147 final_prs = addExportFlagsAndRules target export_set keep_alive
148 rules_for_locals (fromOL all_prs)
149
150 final_pgm = combineEvBinds ds_ev_binds final_prs
151 -- Notice that we put the whole lot in a big Rec, even the foreign binds
152 -- When compiling PrelFloat, which defines data Float = F# Float#
153 -- we want F# to be in scope in the foreign marshalling code!
154 -- You might think it doesn't matter, but the simplifier brings all top-level
155 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
156
157 #ifdef DEBUG
158 -- Debug only as pre-simple-optimisation program may be really big
159 ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
160 #endif
161 ; (ds_binds, ds_rules_for_imps, ds_vects)
162 <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
163 -- The simpleOptPgm gets rid of type
164 -- bindings plus any stupid dead code
165
166 ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
167
168 ; let used_names = mkUsedNames tcg_env
169 ; deps <- mkDependencies tcg_env
170
171 ; used_th <- readIORef tc_splice_used
172 ; dep_files <- readIORef dependent_files
173 ; safe_mode <- finalSafeMode dflags tcg_env
174
175 ; let mod_guts = ModGuts {
176 mg_module = mod,
177 mg_boot = hsc_src == HsBootFile,
178 mg_exports = exports,
179 mg_deps = deps,
180 mg_used_names = used_names,
181 mg_used_th = used_th,
182 mg_dir_imps = imp_mods imports,
183 mg_rdr_env = rdr_env,
184 mg_fix_env = fix_env,
185 mg_warns = warns,
186 mg_anns = anns,
187 mg_tcs = tcs,
188 mg_insts = insts,
189 mg_fam_insts = fam_insts,
190 mg_inst_env = inst_env,
191 mg_fam_inst_env = fam_inst_env,
192 mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
193 mg_rules = ds_rules_for_imps,
194 mg_binds = ds_binds,
195 mg_foreign = ds_fords,
196 mg_hpc_info = ds_hpc_info,
197 mg_modBreaks = modBreaks,
198 mg_vect_decls = ds_vects,
199 mg_vect_info = noVectInfo,
200 mg_safe_haskell = safe_mode,
201 mg_trust_pkg = imp_trust_own_pkg imports,
202 mg_dependent_files = dep_files
203 }
204 ; return (msgs, Just mod_guts)
205 }}}
206
207 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
208 dsImpSpecs imp_specs
209 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
210 ; let (spec_binds, spec_rules) = unzip spec_prs
211 ; return (concatOL spec_binds, spec_rules) }
212
213 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
214 -- Top-level bindings can include coercion bindings, but not via superclasses
215 -- See Note [Top-level evidence]
216 combineEvBinds [] val_prs
217 = [Rec val_prs]
218 combineEvBinds (NonRec b r : bs) val_prs
219 | isId b = combineEvBinds bs ((b,r):val_prs)
220 | otherwise = NonRec b r : combineEvBinds bs val_prs
221 combineEvBinds (Rec prs : bs) val_prs
222 = combineEvBinds bs (prs ++ val_prs)
223
224 {-
225 Note [Top-level evidence]
226 ~~~~~~~~~~~~~~~~~~~~~~~~~
227 Top-level evidence bindings may be mutually recursive with the top-level value
228 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
229 because the occurrence analyser doesn't teke account of type/coercion variables
230 when computing dependencies.
231
232 So we pull out the type/coercion variables (which are in dependency order),
233 and Rec the rest.
234 -}
235
236 deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
237
238 deSugarExpr hsc_env tc_expr
239 = do { let dflags = hsc_dflags hsc_env
240 icntxt = hsc_IC hsc_env
241 rdr_env = ic_rn_gbl_env icntxt
242 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
243 fam_insts = snd (ic_instances icntxt)
244 fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
245 -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
246
247 ; showPass dflags "Desugar"
248
249 -- Do desugaring
250 ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
251 type_env fam_inst_env $
252 dsLExpr tc_expr
253
254 ; case mb_core_expr of
255 Nothing -> return ()
256 Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
257
258 ; return (msgs, mb_core_expr) }
259
260 {-
261 ************************************************************************
262 * *
263 * Add rules and export flags to binders
264 * *
265 ************************************************************************
266 -}
267
268 addExportFlagsAndRules
269 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
270 -> [(Id, t)] -> [(Id, t)]
271 addExportFlagsAndRules target exports keep_alive rules prs
272 = mapFst add_one prs
273 where
274 add_one bndr = add_rules name (add_export name bndr)
275 where
276 name = idName bndr
277
278 ---------- Rules --------
279 -- See Note [Attach rules to local ids]
280 -- NB: the binder might have some existing rules,
281 -- arising from specialisation pragmas
282 add_rules name bndr
283 | Just rules <- lookupNameEnv rule_base name
284 = bndr `addIdSpecialisations` rules
285 | otherwise
286 = bndr
287 rule_base = extendRuleBaseList emptyRuleBase rules
288
289 ---------- Export flag --------
290 -- See Note [Adding export flags]
291 add_export name bndr
292 | dont_discard name = setIdExported bndr
293 | otherwise = bndr
294
295 dont_discard :: Name -> Bool
296 dont_discard name = is_exported name
297 || name `elemNameSet` keep_alive
298
299 -- In interactive mode, we don't want to discard any top-level
300 -- entities at all (eg. do not inline them away during
301 -- simplification), and retain them all in the TypeEnv so they are
302 -- available from the command line.
303 --
304 -- isExternalName separates the user-defined top-level names from those
305 -- introduced by the type checker.
306 is_exported :: Name -> Bool
307 is_exported | targetRetainsAllBindings target = isExternalName
308 | otherwise = (`elemNameSet` exports)
309
310 {-
311 Note [Adding export flags]
312 ~~~~~~~~~~~~~~~~~~~~~~~~~~
313 Set the no-discard flag if either
314 a) the Id is exported
315 b) it's mentioned in the RHS of an orphan rule
316 c) it's in the keep-alive set
317
318 It means that the binding won't be discarded EVEN if the binding
319 ends up being trivial (v = w) -- the simplifier would usually just
320 substitute w for v throughout, but we don't apply the substitution to
321 the rules (maybe we should?), so this substitution would make the rule
322 bogus.
323
324 You might wonder why exported Ids aren't already marked as such;
325 it's just because the type checker is rather busy already and
326 I didn't want to pass in yet another mapping.
327
328 Note [Attach rules to local ids]
329 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
330 Find the rules for locally-defined Ids; then we can attach them
331 to the binders in the top-level bindings
332
333 Reason
334 - It makes the rules easier to look up
335 - It means that transformation rules and specialisations for
336 locally defined Ids are handled uniformly
337 - It keeps alive things that are referred to only from a rule
338 (the occurrence analyser knows about rules attached to Ids)
339 - It makes sure that, when we apply a rule, the free vars
340 of the RHS are more likely to be in scope
341 - The imported rules are carried in the in-scope set
342 which is extended on each iteration by the new wave of
343 local binders; any rules which aren't on the binding will
344 thereby get dropped
345
346
347 ************************************************************************
348 * *
349 * Desugaring transformation rules
350 * *
351 ************************************************************************
352 -}
353
354 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
355 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
356 = putSrcSpanDs loc $
357 do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
358
359 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
360 unsetWOptM Opt_WarnIdentities $
361 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
362
363 ; rhs' <- dsLExpr rhs
364 ; dflags <- getDynFlags
365
366 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
367
368 -- Substitute the dict bindings eagerly,
369 -- and take the body apart into a (f args) form
370 ; case decomposeRuleLhs bndrs'' lhs'' of {
371 Left msg -> do { warnDs msg; return Nothing } ;
372 Right (final_bndrs, fn_id, args) -> do
373
374 { let is_local = isLocalId fn_id
375 -- NB: isLocalId is False of implicit Ids. This is good because
376 -- we don't want to attach rules to the bindings of implicit Ids,
377 -- because they don't show up in the bindings until just before code gen
378 fn_name = idName fn_id
379 final_rhs = simpleOptExpr rhs'' -- De-crap it
380 rule = mkRule False {- Not auto -} is_local
381 (unLoc name) act fn_name final_bndrs args
382 final_rhs
383
384 inline_shadows_rule -- Function can be inlined before rule fires
385 | wopt Opt_WarnInlineRuleShadowing dflags
386 , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)
387 -- If imported with no unfolding, no worries
388 = case (idInlineActivation fn_id, act) of
389 (NeverActive, _) -> False
390 (AlwaysActive, _) -> True
391 (ActiveBefore {}, _) -> True
392 (ActiveAfter {}, NeverActive) -> True
393 (ActiveAfter n, ActiveAfter r) -> r < n -- Rule active strictly first
394 (ActiveAfter {}, AlwaysActive) -> False
395 (ActiveAfter {}, ActiveBefore {}) -> False
396 | otherwise = False
397
398 ; when inline_shadows_rule $
399 warnDs (vcat [ hang (ptext (sLit "Rule")
400 <+> doubleQuotes (ftext $ unLoc name)
401 <+> ptext (sLit "may never fire"))
402 2 (ptext (sLit "because") <+> quotes (ppr fn_id)
403 <+> ptext (sLit "might inline first"))
404 , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")
405 <+> quotes (ppr fn_id) ])
406
407 ; return (Just rule)
408 } } }
409
410 -- See Note [Desugaring coerce as cast]
411 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
412 unfold_coerce bndrs lhs rhs = do
413 (bndrs', wrap) <- go bndrs
414 return (bndrs', wrap lhs, wrap rhs)
415 where
416 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
417 go [] = return ([], id)
418 go (v:vs)
419 | Just (tc, args) <- splitTyConApp_maybe (idType v)
420 , tc == coercibleTyCon = do
421 let ty' = mkTyConApp eqReprPrimTyCon args
422 v' <- mkDerivedLocalM mkRepEqOcc v ty'
423
424 (bndrs, wrap) <- go vs
425 return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
426 | otherwise = do
427 (bndrs,wrap) <- go vs
428 return (v:bndrs, wrap)
429
430 {-
431 Note [Desugaring RULE left hand sides]
432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
433 For the LHS of a RULE we do *not* want to desugar
434 [x] to build (\cn. x `c` n)
435 We want to leave explicit lists simply as chains
436 of cons's. We can achieve that slightly indirectly by
437 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
438
439 That keeps the desugaring of list comprehensions simple too.
440
441
442
443 Nor do we want to warn of conversion identities on the LHS;
444 the rule is precisly to optimise them:
445 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
446
447
448 Note [Desugaring coerce as cast]
449 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
450 We want the user to express a rule saying roughly “mapping a coercion over a
451 list can be replaced by a coercion”. But the cast operator of Core () cannot
452 be written in Haskell. So we use `coerce` for that (#2110). The user writes
453 map coerce = coerce
454 as a RULE, and this optimizes any kind of mapped' casts aways, including `map
455 MkNewtype`.
456
457 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
458 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
459 `let c = MkCoercible co in ...`. This is later simplified to the desired form
460 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
461
462 ************************************************************************
463 * *
464 * Desugaring vectorisation declarations
465 * *
466 ************************************************************************
467 -}
468
469 dsVect :: LVectDecl Id -> DsM CoreVect
470 dsVect (L loc (HsVect (L _ v) rhs))
471 = putSrcSpanDs loc $
472 do { rhs' <- dsLExpr rhs
473 ; return $ Vect v rhs'
474 }
475 dsVect (L _loc (HsNoVect (L _ v)))
476 = return $ NoVect v
477 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
478 = return $ VectType isScalar tycon' rhs_tycon
479 where
480 tycon' | Just ty <- coreView $ mkTyConTy tycon
481 , (tycon', []) <- splitTyConApp ty = tycon'
482 | otherwise = tycon
483 dsVect vd@(L _ (HsVectTypeIn _ _ _))
484 = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
485 dsVect (L _loc (HsVectClassOut cls))
486 = return $ VectClass (classTyCon cls)
487 dsVect vc@(L _ (HsVectClassIn _))
488 = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
489 dsVect (L _loc (HsVectInstOut inst))
490 = return $ VectInst (instanceDFunId inst)
491 dsVect vi@(L _ (HsVectInstIn _))
492 = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)