2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The Desugarer: turning HsSyn into Core.
9 module Desugar ( deSugar, deSugarExpr ) where
22 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
28 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
29 -- depends on DsExpr.hi-boot.
35 import CoreMonad ( endPass, CoreToDo(..) )
53 %************************************************************************
55 %* The main function: deSugar
57 %************************************************************************
61 -- | Main entry point to the desugarer.
62 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
63 -- Can modify PCS by faulting in more declarations
67 tcg_env@(TcGblEnv { tcg_mod = mod,
69 tcg_type_env = type_env,
70 tcg_imports = imports,
71 tcg_exports = exports,
73 tcg_rdr_env = rdr_env,
74 tcg_fix_env = fix_env,
75 tcg_inst_env = inst_env,
76 tcg_fam_inst_env = fam_inst_env,
80 tcg_imp_specs = imp_specs,
81 tcg_ev_binds = ev_binds,
86 tcg_fam_insts = fam_insts,
87 tcg_hpc = other_hpc_info })
89 = do { let dflags = hsc_dflags hsc_env
90 ; showPass dflags "Desugar"
92 -- Desugar the program
93 ; let export_set = availsToNameSet exports
94 ; let auto_scc = mkAutoScc dflags mod export_set
95 ; let target = hscTarget dflags
96 ; let hpcInfo = emptyHpcInfo other_hpc_info
100 return (emptyMessages,
101 Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
130 (binds_cvr,ds_hpc_info, modBreaks)
132 || target == HscInterpreted)
133 && (not (isHsBoot hsc_src))
134 then addCoverageTicksToBinds dflags mod mod_loc
135 (typeEnvTyCons type_env) binds
136 else return (binds, hpcInfo, emptyModBreaks)
137 initDs hsc_env mod rdr_env type_env $ do
138 do { ds_ev_binds <- dsEvBinds ev_binds
139 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
140 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
141 ; (ds_fords, foreign_prs) <- dsForeigns fords
142 ; ds_rules <- mapMaybeM dsRule rules
143 ; ds_vects <- mapM dsVect vects
144 ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
145 ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined
146 ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
147 ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined
148 ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
149 ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
150 ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined
151 ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined
152 ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined
153 ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
154 ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
155 ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
156 ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
157 ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
158 ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
159 ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
160 ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
161 ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
162 ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
163 ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
164 ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
165 ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
166 ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
167 ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
168 ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
169 ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
170 ; hetmet_pga_loopl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopl_name else return undefined
171 ; hetmet_pga_loopr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopr_name else return undefined
173 | opt_Hpc = hpcInitCode mod ds_hpc_info
175 ; return ( ds_ev_binds
176 , foreign_prs `appOL` core_prs `appOL` spec_prs
177 , spec_rules ++ ds_rules, ds_vects
178 , ds_fords `appendStubC` hpc_init
179 , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
182 , hetmet_flattened_id
184 , hetmet_PGArrow_unit
185 , hetmet_PGArrow_tensor
186 , hetmet_PGArrow_exponent
193 , hetmet_pga_uncancell
194 , hetmet_pga_uncancelr
209 Nothing -> return (msgs, Nothing) ;
210 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
211 , hetmet_brak, hetmet_esc
214 , hetmet_flattened_id
216 , hetmet_PGArrow_unit
217 , hetmet_PGArrow_tensor
218 , hetmet_PGArrow_exponent
225 , hetmet_pga_uncancell
226 , hetmet_pga_uncancelr
240 { -- Add export flags to bindings
241 keep_alive <- readIORef keep_var
242 ; let (rules_for_locals, rules_for_imps)
243 = partition isLocalRule all_rules
244 final_prs = addExportFlagsAndRules target
245 export_set keep_alive rules_for_locals (fromOL all_prs)
247 final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
248 in if dopt Opt_F_simpleopt_before_flatten dflags
250 else simplifyBinds comb
251 -- Notice that we put the whole lot in a big Rec, even the foreign binds
252 -- When compiling PrelFloat, which defines data Float = F# Float#
253 -- we want F# to be in scope in the foreign marshalling code!
254 -- You might think it doesn't matter, but the simplifier brings all top-level
255 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
257 -- Lint result if necessary, and print
258 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
259 (vcat [ pprCoreBindings final_pgm
260 , pprRules rules_for_imps ])
262 ; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags
263 then simpleOptPgm dflags final_pgm rules_for_imps
264 else return (final_pgm, rules_for_imps)
266 ; ds_binds <- if dopt Opt_F_coqpass dflags
267 then do { us <- mkSplitUniqSupply '~'
268 ; let do_flatten = dopt Opt_F_flatten dflags
269 ; let do_skolemize = dopt Opt_F_skolemize dflags
270 ; return (coqPassCoreToCore
282 hetmet_PGArrow_tensor
283 hetmet_PGArrow_exponent
305 else return final_pgm
307 ; (ds_binds', ds_rules_for_imps) <- if dopt Opt_F_simpleopt_before_flatten dflags
308 then return (ds_binds, rules_for_imps')
309 else simpleOptPgm dflags ds_binds rules_for_imps'
310 -- The simpleOptPgm gets rid of type
311 -- bindings plus any stupid dead code
313 ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
315 ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
317 ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
319 ; let used_names = mkUsedNames tcg_env
320 ; deps <- mkDependencies tcg_env
322 ; let mod_guts = ModGuts {
324 mg_boot = isHsBoot hsc_src,
325 mg_exports = exports,
327 mg_used_names = used_names,
328 mg_dir_imps = imp_mods imports,
329 mg_rdr_env = rdr_env,
330 mg_fix_env = fix_env,
335 mg_fam_insts = fam_insts,
336 mg_inst_env = inst_env,
337 mg_fam_inst_env = fam_inst_env,
338 mg_rules = ds_rules_for_imps,
339 mg_binds = ds_binds',
340 mg_foreign = ds_fords,
341 mg_hpc_info = ds_hpc_info,
342 mg_modBreaks = modBreaks,
343 mg_vect_decls = ds_vects,
344 mg_vect_info = noVectInfo
346 ; return (msgs, Just mod_guts)
349 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
351 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
352 ; let (spec_binds, spec_rules) = unzip spec_prs
353 ; return (concatOL spec_binds, spec_rules) }
355 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
356 -- Top-level bindings can include coercion bindings, but not via superclasses
357 -- See Note [Top-level evidence]
358 combineEvBinds [] val_prs
360 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
361 | isId b = combineEvBinds bs ((b,r):val_prs)
362 | otherwise = NonRec b r : combineEvBinds bs val_prs
363 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
364 = combineEvBinds bs (prs ++ val_prs)
365 combineEvBinds (CaseEvBind x _ _ : _) _
366 = pprPanic "topEvBindPairs" (ppr x)
369 Note [Top-level evidence]
370 ~~~~~~~~~~~~~~~~~~~~~~~~~
371 Top-level evidence bindings may be mutually recursive with the top-level value
372 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
373 because the occurrence analyser doesn't teke account of type/coercion variables
374 when computing dependencies.
376 So we pull out the type/coercion variables (which are in dependency order),
381 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
382 mkAutoScc dflags mod exports
383 | not opt_SccProfilingOn -- No profiling
385 -- Add auto-scc on all top-level things
386 | dopt Opt_AutoSccsOnAllToplevs dflags
387 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
388 -- See #1641. This is pretty yucky, but I can't see a better way
389 -- to identify compiler-generated Ids, and at least this should
391 -- Only on exported things
392 | dopt Opt_AutoSccsOnExportedToplevs dflags
393 = AddSccs mod (\id -> idName id `elemNameSet` exports)
397 deSugarExpr :: HscEnv
398 -> Module -> GlobalRdrEnv -> TypeEnv
400 -> IO (Messages, Maybe CoreExpr)
401 -- Prints its own errors; returns Nothing if error occurred
403 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
404 let dflags = hsc_dflags hsc_env
405 showPass dflags "Desugar"
408 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
412 Nothing -> return (msgs, Nothing)
416 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
418 return (msgs, Just expr)
421 %************************************************************************
423 %* Add rules and export flags to binders
425 %************************************************************************
428 addExportFlagsAndRules
429 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
430 -> [(Id, t)] -> [(Id, t)]
431 addExportFlagsAndRules target exports keep_alive rules prs
434 add_one bndr = add_rules name (add_export name bndr)
438 ---------- Rules --------
439 -- See Note [Attach rules to local ids]
440 -- NB: the binder might have some existing rules,
441 -- arising from specialisation pragmas
443 | Just rules <- lookupNameEnv rule_base name
444 = bndr `addIdSpecialisations` rules
447 rule_base = extendRuleBaseList emptyRuleBase rules
449 ---------- Export flag --------
450 -- See Note [Adding export flags]
452 | dont_discard name = setIdExported bndr
455 dont_discard :: Name -> Bool
456 dont_discard name = is_exported name
457 || name `elemNameSet` keep_alive
459 -- In interactive mode, we don't want to discard any top-level
460 -- entities at all (eg. do not inline them away during
461 -- simplification), and retain them all in the TypeEnv so they are
462 -- available from the command line.
464 -- isExternalName separates the user-defined top-level names from those
465 -- introduced by the type checker.
466 is_exported :: Name -> Bool
467 is_exported | target == HscInterpreted = isExternalName
468 | otherwise = (`elemNameSet` exports)
472 Note [Adding export flags]
473 ~~~~~~~~~~~~~~~~~~~~~~~~~~
474 Set the no-discard flag if either
475 a) the Id is exported
476 b) it's mentioned in the RHS of an orphan rule
477 c) it's in the keep-alive set
479 It means that the binding won't be discarded EVEN if the binding
480 ends up being trivial (v = w) -- the simplifier would usually just
481 substitute w for v throughout, but we don't apply the substitution to
482 the rules (maybe we should?), so this substitution would make the rule
485 You might wonder why exported Ids aren't already marked as such;
486 it's just because the type checker is rather busy already and
487 I didn't want to pass in yet another mapping.
489 Note [Attach rules to local ids]
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491 Find the rules for locally-defined Ids; then we can attach them
492 to the binders in the top-level bindings
495 - It makes the rules easier to look up
496 - It means that transformation rules and specialisations for
497 locally defined Ids are handled uniformly
498 - It keeps alive things that are referred to only from a rule
499 (the occurrence analyser knows about rules attached to Ids)
500 - It makes sure that, when we apply a rule, the free vars
501 of the RHS are more likely to be in scope
502 - The imported rules are carried in the in-scope set
503 which is extended on each iteration by the new wave of
504 local binders; any rules which aren't on the binding will
508 %************************************************************************
510 %* Desugaring transformation rules
512 %************************************************************************
515 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
516 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
518 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
520 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
521 unsetOptM Opt_WarnIdentities $
522 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
524 ; rhs' <- dsLExpr rhs
526 -- Substitute the dict bindings eagerly,
527 -- and take the body apart into a (f args) form
528 ; case decomposeRuleLhs bndrs' lhs' of {
529 Left msg -> do { warnDs msg; return Nothing } ;
530 Right (final_bndrs, fn_id, args) -> do
532 { let is_local = isLocalId fn_id
533 -- NB: isLocalId is False of implicit Ids. This is good becuase
534 -- we don't want to attach rules to the bindings of implicit Ids,
535 -- because they don't show up in the bindings until just before code gen
536 fn_name = idName fn_id
537 final_rhs = simpleOptExpr rhs' -- De-crap it
538 rule = mkRule False {- Not auto -} is_local
539 name act fn_name final_bndrs args final_rhs
544 Note [Desugaring RULE left hand sides]
545 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
546 For the LHS of a RULE we do *not* want to desugar
547 [x] to build (\cn. x `c` n)
548 We want to leave explicit lists simply as chains
549 of cons's. We can achieve that slightly indirectly by
550 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
552 That keeps the desugaring of list comprehensions simple too.
556 Nor do we want to warn of conversion identities on the LHS;
557 the rule is precisly to optimise them:
558 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
561 %************************************************************************
563 %* Desugaring vectorisation declarations
565 %************************************************************************
568 dsVect :: LVectDecl Id -> DsM CoreVect
569 dsVect (L loc (HsVect v rhs))
571 do { rhs' <- fmapMaybeM dsLExpr rhs
572 ; return $ Vect (unLoc v) rhs'
574 -- dsVect (L loc (HsVect v Nothing))
575 -- = return $ Vect v Nothing
576 -- dsVect (L loc (HsVect v (Just rhs)))
577 -- = putSrcSpanDs loc $
578 -- do { rhs' <- dsLExpr rhs
579 -- ; return $ Vect v (Just rhs')
587 -- Simplification routines run before the flattener. We can't use
588 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
589 -- let-binding groups.
591 simplify :: Expr CoreBndr -> Expr CoreBndr
592 simplify (Var v) = Var v
593 simplify (App e1 e2) = App (simplify e1) (simplify e2)
594 simplify (Lit lit) = Lit lit
595 simplify (Note note e) = Note note (simplify e)
596 simplify (Cast e co) = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
598 else Cast (simplify e) co
599 simplify (Lam v e) = Lam v (simplify e)
600 simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
601 simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
602 simplify (Type t) = Type t
603 simplify (Coercion co) = Coercion co
605 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
606 simplifyBind (NonRec b e) = [NonRec b (simplify e)]
607 simplifyBind (Rec []) = []
608 simplifyBind (Rec (rbs@((b,e):rbs'))) =
609 if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
610 then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
611 else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
613 simplifyBinds = concatMap simplifyBind