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
24 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
30 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
31 -- depends on DsExpr.hi-boot.
37 import CoreMonad ( endPass, CoreToDo(..) )
55 %************************************************************************
57 %* The main function: deSugar
59 %************************************************************************
63 -- | Main entry point to the desugarer.
64 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
65 -- Can modify PCS by faulting in more declarations
69 tcg_env@(TcGblEnv { tcg_mod = mod,
71 tcg_type_env = type_env,
72 tcg_imports = imports,
73 tcg_exports = exports,
75 tcg_rdr_env = rdr_env,
76 tcg_fix_env = fix_env,
77 tcg_inst_env = inst_env,
78 tcg_fam_inst_env = fam_inst_env,
82 tcg_imp_specs = imp_specs,
83 tcg_ev_binds = ev_binds,
88 tcg_fam_insts = fam_insts,
89 tcg_hpc = other_hpc_info })
91 = do { let dflags = hsc_dflags hsc_env
92 ; showPass dflags "Desugar"
94 -- Desugar the program
95 ; let export_set = availsToNameSet exports
96 ; let auto_scc = mkAutoScc dflags mod export_set
97 ; let target = hscTarget dflags
98 ; let hpcInfo = emptyHpcInfo other_hpc_info
102 return (emptyMessages,
103 Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined))
105 (binds_cvr,ds_hpc_info, modBreaks)
107 || target == HscInterpreted)
108 && (not (isHsBoot hsc_src))
109 then addCoverageTicksToBinds dflags mod mod_loc
110 (typeEnvTyCons type_env) binds
111 else return (binds, hpcInfo, emptyModBreaks)
113 initDs hsc_env mod rdr_env type_env $ do
114 do { ds_ev_binds <- dsEvBinds ev_binds
115 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
116 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
117 ; (ds_fords, foreign_prs) <- dsForeigns fords
118 ; ds_rules <- mapMaybeM dsRule rules
119 ; ds_vects <- mapM dsVect vects
120 ; junk <- if dopt Opt_F_coqpass dflags
121 then do { hetmet_brak_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_brak"))
122 ; hetmet_brak <- dsLookupGlobalId hetmet_brak_name
123 ; hetmet_esc_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_esc"))
124 ; hetmet_esc <- dsLookupGlobalId hetmet_esc_name
125 ; hetmet_flatten_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_flatten"))
126 ; hetmet_flatten <- dsLookupGlobalId hetmet_flatten_name
127 ; hetmet_unflatten_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "pga_unflatten"))
128 ; hetmet_unflatten <- dsLookupGlobalId hetmet_unflatten_name
129 ; hetmet_flattened_id_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "pga_flattened_id"))
130 ; hetmet_flattened_id <- dsLookupGlobalId hetmet_flattened_id_name
131 ; hetmet_PGArrow_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS tcName (fsLit "PGArrow"))
132 ; hetmet_PGArrow <- dsLookupTyCon hetmet_PGArrow_name
133 ; hetmet_PGArrow_unit_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowUnit"))
134 ; hetmet_PGArrow_unit <- dsLookupTyCon hetmet_PGArrow_unit_name
135 ; hetmet_PGArrow_tensor_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowTensor"))
136 ; hetmet_PGArrow_tensor <- dsLookupTyCon hetmet_PGArrow_tensor_name
137 ; hetmet_PGArrow_exponent_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowExponent"))
138 ; hetmet_PGArrow_exponent <- dsLookupTyCon hetmet_PGArrow_exponent_name
139 ; hetmet_pga_id_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_id"))
140 ; hetmet_pga_id <- dsLookupGlobalId hetmet_pga_id_name
141 ; hetmet_pga_comp_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_comp"))
142 ; hetmet_pga_comp <- dsLookupGlobalId hetmet_pga_comp_name
143 ; hetmet_pga_first_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_first"))
144 ; hetmet_pga_first <- dsLookupGlobalId hetmet_pga_first_name
145 ; hetmet_pga_second_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_second"))
146 ; hetmet_pga_second <- dsLookupGlobalId hetmet_pga_second_name
147 ; hetmet_pga_cancell_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_cancell"))
148 ; hetmet_pga_cancell <- dsLookupGlobalId hetmet_pga_cancell_name
149 ; hetmet_pga_cancelr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_cancelr"))
150 ; hetmet_pga_cancelr <- dsLookupGlobalId hetmet_pga_cancelr_name
151 ; hetmet_pga_uncancell_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_uncancell"))
152 ; hetmet_pga_uncancell <- dsLookupGlobalId hetmet_pga_uncancell_name
153 ; hetmet_pga_uncancelr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_uncancelr"))
154 ; hetmet_pga_uncancelr <- dsLookupGlobalId hetmet_pga_uncancelr_name
155 ; hetmet_pga_assoc_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_assoc"))
156 ; hetmet_pga_assoc <- dsLookupGlobalId hetmet_pga_assoc_name
157 ; hetmet_pga_unassoc_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_unassoc"))
158 ; hetmet_pga_unassoc <- dsLookupGlobalId hetmet_pga_unassoc_name
159 ; hetmet_pga_copy_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_copy"))
160 ; hetmet_pga_copy <- dsLookupGlobalId hetmet_pga_copy_name
161 ; hetmet_pga_drop_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_drop"))
162 ; hetmet_pga_drop <- dsLookupGlobalId hetmet_pga_drop_name
163 ; hetmet_pga_swap_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_swap"))
164 ; hetmet_pga_swap <- dsLookupGlobalId hetmet_pga_swap_name
165 ; hetmet_pga_applyl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_applyl"))
166 ; hetmet_pga_applyl <- dsLookupGlobalId hetmet_pga_applyl_name
167 ; hetmet_pga_applyr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_applyr"))
168 ; hetmet_pga_applyr <- dsLookupGlobalId hetmet_pga_applyr_name
169 ; hetmet_pga_curryl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_curryl"))
170 ; hetmet_pga_curryl <- dsLookupGlobalId hetmet_pga_curryl_name
171 ; hetmet_pga_curryr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_curryr"))
172 ; hetmet_pga_curryr <- dsLookupGlobalId hetmet_pga_curryr_name
173 ; hetmet_pga_loopl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_loopl"))
174 ; hetmet_pga_loopl <- dsLookupGlobalId hetmet_pga_loopl_name
175 ; hetmet_pga_loopr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_loopr"))
176 ; hetmet_pga_loopr <- dsLookupGlobalId hetmet_pga_loopr_name
177 ; return ( hetmet_brak
181 , hetmet_flattened_id
183 , hetmet_PGArrow_unit
184 , hetmet_PGArrow_tensor
185 , hetmet_PGArrow_exponent
192 , hetmet_pga_uncancell
193 , hetmet_pga_uncancelr
206 else return undefined
208 | opt_Hpc = hpcInitCode mod ds_hpc_info
210 ; return ( ds_ev_binds
211 , foreign_prs `appOL` core_prs `appOL` spec_prs
212 , spec_rules ++ ds_rules, ds_vects
213 , ds_fords `appendStubC` hpc_init
214 , ds_hpc_info, modBreaks, junk)
218 Nothing -> return (msgs, Nothing) ;
219 Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks, junk) -> do
221 { -- Add export flags to bindings
222 keep_alive <- readIORef keep_var
223 ; let (rules_for_locals, rules_for_imps)
224 = partition isLocalRule all_rules
225 final_prs = addExportFlagsAndRules target
226 export_set keep_alive rules_for_locals (fromOL all_prs)
228 final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
229 in if dopt Opt_F_simpleopt_before_flatten dflags
231 else simplifyBinds comb
232 -- Notice that we put the whole lot in a big Rec, even the foreign binds
233 -- When compiling PrelFloat, which defines data Float = F# Float#
234 -- we want F# to be in scope in the foreign marshalling code!
235 -- You might think it doesn't matter, but the simplifier brings all top-level
236 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
238 ; (final_pgm1, rules_for_imps1, ds_vects1) <- if dopt Opt_F_simpleopt_before_flatten dflags
239 then simpleOptPgm dflags final_pgm rules_for_imps vects0
240 else return (final_pgm, rules_for_imps, vects0)
242 ; ds_binds1 <- if dopt Opt_F_coqpass dflags
243 then do { us <- mkSplitUniqSupply '~'
244 ; let do_flatten = dopt Opt_F_flatten dflags
245 ; let do_skolemize = dopt Opt_F_skolemize dflags
251 hetmet_flattened_id ,
253 hetmet_PGArrow_unit ,
254 hetmet_PGArrow_tensor ,
255 hetmet_PGArrow_exponent ,
262 hetmet_pga_uncancell ,
263 hetmet_pga_uncancelr ,
274 hetmet_pga_loopr ) ->
275 return (coqPassCoreToCore
287 hetmet_PGArrow_tensor
288 hetmet_PGArrow_exponent
312 else return final_pgm
314 ; (ds_binds2, ds_rules_for_imps2, ds_vects2) <- if dopt Opt_F_simpleopt_before_flatten dflags
315 then return (ds_binds1, rules_for_imps1, ds_vects1)
316 else simpleOptPgm dflags ds_binds1 rules_for_imps1 ds_vects1
317 -- The simpleOptPgm gets rid of type
318 -- bindings plus any stupid dead code
320 ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds1
322 ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds1)
324 ; (ds_binds3, ds_rules_for_imps3, ds_vects3)
325 <- simpleOptPgm dflags ds_binds2 ds_rules_for_imps2 ds_vects2
326 -- The simpleOptPgm gets rid of type
327 -- bindings plus any stupid dead code
329 ; endPass dflags CoreDesugar ds_binds3 ds_rules_for_imps3
331 ; let used_names = mkUsedNames tcg_env
332 ; deps <- mkDependencies tcg_env
334 ; let mod_guts = ModGuts {
336 mg_boot = isHsBoot hsc_src,
337 mg_exports = exports,
339 mg_used_names = used_names,
340 mg_dir_imps = imp_mods imports,
341 mg_rdr_env = rdr_env,
342 mg_fix_env = fix_env,
347 mg_fam_insts = fam_insts,
348 mg_inst_env = inst_env,
349 mg_fam_inst_env = fam_inst_env,
350 mg_rules = ds_rules_for_imps3,
351 mg_binds = ds_binds3,
352 mg_foreign = ds_fords,
353 mg_hpc_info = ds_hpc_info,
354 mg_modBreaks = modBreaks,
355 mg_vect_decls = ds_vects2,
356 mg_vect_info = noVectInfo
358 ; return (msgs, Just mod_guts)
361 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
363 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
364 ; let (spec_binds, spec_rules) = unzip spec_prs
365 ; return (concatOL spec_binds, spec_rules) }
367 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
368 -- Top-level bindings can include coercion bindings, but not via superclasses
369 -- See Note [Top-level evidence]
370 combineEvBinds [] val_prs
372 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
373 | isId b = combineEvBinds bs ((b,r):val_prs)
374 | otherwise = NonRec b r : combineEvBinds bs val_prs
375 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
376 = combineEvBinds bs (prs ++ val_prs)
377 combineEvBinds (CaseEvBind x _ _ : _) _
378 = pprPanic "topEvBindPairs" (ppr x)
381 Note [Top-level evidence]
382 ~~~~~~~~~~~~~~~~~~~~~~~~~
383 Top-level evidence bindings may be mutually recursive with the top-level value
384 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
385 because the occurrence analyser doesn't teke account of type/coercion variables
386 when computing dependencies.
388 So we pull out the type/coercion variables (which are in dependency order),
393 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
394 mkAutoScc dflags mod exports
395 | not opt_SccProfilingOn -- No profiling
397 -- Add auto-scc on all top-level things
398 | dopt Opt_AutoSccsOnAllToplevs dflags
399 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
400 -- See #1641. This is pretty yucky, but I can't see a better way
401 -- to identify compiler-generated Ids, and at least this should
403 -- Only on exported things
404 | dopt Opt_AutoSccsOnExportedToplevs dflags
405 = AddSccs mod (\id -> idName id `elemNameSet` exports)
409 deSugarExpr :: HscEnv
410 -> Module -> GlobalRdrEnv -> TypeEnv
412 -> IO (Messages, Maybe CoreExpr)
413 -- Prints its own errors; returns Nothing if error occurred
415 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
416 let dflags = hsc_dflags hsc_env
417 showPass dflags "Desugar"
420 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
424 Nothing -> return (msgs, Nothing)
428 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
430 return (msgs, Just expr)
433 %************************************************************************
435 %* Add rules and export flags to binders
437 %************************************************************************
440 addExportFlagsAndRules
441 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
442 -> [(Id, t)] -> [(Id, t)]
443 addExportFlagsAndRules target exports keep_alive rules prs
446 add_one bndr = add_rules name (add_export name bndr)
450 ---------- Rules --------
451 -- See Note [Attach rules to local ids]
452 -- NB: the binder might have some existing rules,
453 -- arising from specialisation pragmas
455 | Just rules <- lookupNameEnv rule_base name
456 = bndr `addIdSpecialisations` rules
459 rule_base = extendRuleBaseList emptyRuleBase rules
461 ---------- Export flag --------
462 -- See Note [Adding export flags]
464 | dont_discard name = setIdExported bndr
467 dont_discard :: Name -> Bool
468 dont_discard name = is_exported name
469 || name `elemNameSet` keep_alive
471 -- In interactive mode, we don't want to discard any top-level
472 -- entities at all (eg. do not inline them away during
473 -- simplification), and retain them all in the TypeEnv so they are
474 -- available from the command line.
476 -- isExternalName separates the user-defined top-level names from those
477 -- introduced by the type checker.
478 is_exported :: Name -> Bool
479 is_exported | target == HscInterpreted = isExternalName
480 | otherwise = (`elemNameSet` exports)
484 Note [Adding export flags]
485 ~~~~~~~~~~~~~~~~~~~~~~~~~~
486 Set the no-discard flag if either
487 a) the Id is exported
488 b) it's mentioned in the RHS of an orphan rule
489 c) it's in the keep-alive set
491 It means that the binding won't be discarded EVEN if the binding
492 ends up being trivial (v = w) -- the simplifier would usually just
493 substitute w for v throughout, but we don't apply the substitution to
494 the rules (maybe we should?), so this substitution would make the rule
497 You might wonder why exported Ids aren't already marked as such;
498 it's just because the type checker is rather busy already and
499 I didn't want to pass in yet another mapping.
501 Note [Attach rules to local ids]
502 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
503 Find the rules for locally-defined Ids; then we can attach them
504 to the binders in the top-level bindings
507 - It makes the rules easier to look up
508 - It means that transformation rules and specialisations for
509 locally defined Ids are handled uniformly
510 - It keeps alive things that are referred to only from a rule
511 (the occurrence analyser knows about rules attached to Ids)
512 - It makes sure that, when we apply a rule, the free vars
513 of the RHS are more likely to be in scope
514 - The imported rules are carried in the in-scope set
515 which is extended on each iteration by the new wave of
516 local binders; any rules which aren't on the binding will
520 %************************************************************************
522 %* Desugaring transformation rules
524 %************************************************************************
527 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
528 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
530 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
532 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
533 unsetOptM Opt_WarnIdentities $
534 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
536 ; rhs' <- dsLExpr rhs
538 -- Substitute the dict bindings eagerly,
539 -- and take the body apart into a (f args) form
540 ; case decomposeRuleLhs bndrs' lhs' of {
541 Left msg -> do { warnDs msg; return Nothing } ;
542 Right (final_bndrs, fn_id, args) -> do
544 { let is_local = isLocalId fn_id
545 -- NB: isLocalId is False of implicit Ids. This is good becuase
546 -- we don't want to attach rules to the bindings of implicit Ids,
547 -- because they don't show up in the bindings until just before code gen
548 fn_name = idName fn_id
549 final_rhs = simpleOptExpr rhs' -- De-crap it
550 rule = mkRule False {- Not auto -} is_local
551 name act fn_name final_bndrs args final_rhs
556 Note [Desugaring RULE left hand sides]
557 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
558 For the LHS of a RULE we do *not* want to desugar
559 [x] to build (\cn. x `c` n)
560 We want to leave explicit lists simply as chains
561 of cons's. We can achieve that slightly indirectly by
562 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
564 That keeps the desugaring of list comprehensions simple too.
568 Nor do we want to warn of conversion identities on the LHS;
569 the rule is precisly to optimise them:
570 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
573 %************************************************************************
575 %* Desugaring vectorisation declarations
577 %************************************************************************
580 dsVect :: LVectDecl Id -> DsM CoreVect
581 dsVect (L loc (HsVect (L _ v) rhs))
583 do { rhs' <- fmapMaybeM dsLExpr rhs
584 ; return $ Vect v rhs'
586 dsVect (L _loc (HsNoVect (L _ v)))
594 -- Simplification routines run before the flattener. We can't use
595 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
596 -- let-binding groups.
598 simplify :: Expr CoreBndr -> Expr CoreBndr
599 simplify (Var v) = Var v
600 simplify (App e1 e2) = App (simplify e1) (simplify e2)
601 simplify (Lit lit) = Lit lit
602 simplify (Note note e) = Note note (simplify e)
603 simplify (Cast e co) = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
605 else Cast (simplify e) co
606 simplify (Lam v e) = Lam v (simplify e)
607 simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
608 simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
609 simplify (Type t) = Type t
610 simplify (Coercion co) = Coercion co
612 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
613 simplifyBind (NonRec b e) = [NonRec b (simplify e)]
614 simplifyBind (Rec []) = []
615 simplifyBind (Rec (rbs@((b,e):rbs'))) =
616 if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
617 then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
618 else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
620 simplifyBinds = concatMap simplifyBind