import Module
import RdrName
import NameSet
-import VarSet
import Rules
-import CoreLint
-import CoreFVs
+import CoreMonad ( endPass, CoreToDo(..) )
import ErrUtils
import Outputable
import SrcLoc
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let final_prs = addExportFlags target export_set
- keep_alive all_prs ds_rules
+ keep_alive all_prs
ds_binds = [Rec final_prs]
-- Notice that we put the whole lot in a big Rec, even the foreign binds
-- When compiling PrelFloat, which defines data Float = F# Float#
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
-- Lint result if necessary
- ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+ ; endPass dflags CoreDesugar ds_binds ds_rules
-- Dump output
; doIfSet (dopt Opt_D_dump_ds dflags)
-- it's just because the type checker is rather busy already and
-- I didn't want to pass in yet another mapping.
-addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [CoreRule]
+addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)]
-> [(Id, t)]
-addExportFlags target exports keep_alive prs rules
+addExportFlags target exports keep_alive prs
= [(add_export bndr, rhs) | (bndr,rhs) <- prs]
where
add_export bndr
| dont_discard bndr = setIdExported bndr
| otherwise = bndr
- orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
- | rule <- rules,
- not (isLocalRule rule) ]
- -- A non-local rule keeps alive the free vars of its right-hand side.
- -- (A "non-local" is one whose head function is not locally defined.)
- -- Local rules are (later, after gentle simplification)
- -- attached to the Id, and that keeps the rhs free vars alive.
-
dont_discard bndr = is_exported name
|| name `elemNameSet` keep_alive
- || bndr `elemVarSet` orph_rhs_fvs
where
name = idName bndr
dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
- ; lhs' <- dsLExpr lhs
+
+ ; lhs' <- unsetOptM Opt_EnableRewriteRules $
+ dsLExpr lhs -- Note [Desugaring RULE lhss]
+
; rhs' <- dsLExpr rhs
-- Substitute the dict bindings eagerly,
-- NB: isLocalId is False of implicit Ids. This is good becuase
-- 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
-
- rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
- ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs',
- ru_rough = roughTopNames args,
- ru_local = local_rule }
+ fn_name = idName fn_id
+ rule = mkRule local_rule name act fn_name bndrs args rhs'
; return (Just rule)
} } }
where
msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
2 (ppr lhs)
\end{code}
+
+Note [Desugaring RULE left hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+switching off EnableRewriteRules. See DsExpr.dsExplicitList.
+
+That keeps the desugaring of list comprehensions simple too.