summaryrefslogtreecommitdiff
path: root/ghc/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/deSugar')
-rw-r--r--ghc/compiler/deSugar/Desugar.lhs14
-rw-r--r--ghc/compiler/deSugar/DsBinds.lhs155
-rw-r--r--ghc/compiler/deSugar/DsCCall.lhs12
-rw-r--r--ghc/compiler/deSugar/DsExpr.lhs10
-rw-r--r--ghc/compiler/deSugar/DsGRHSs.lhs4
-rw-r--r--ghc/compiler/deSugar/DsLoop.lhi2
-rw-r--r--ghc/compiler/deSugar/DsLoop_1_3.lhi5
-rw-r--r--ghc/compiler/deSugar/DsMonad.lhs6
-rw-r--r--ghc/compiler/deSugar/DsUtils.lhs4
-rw-r--r--ghc/compiler/deSugar/Match.lhs6
-rw-r--r--ghc/compiler/deSugar/MatchLit.lhs2
11 files changed, 124 insertions, 96 deletions
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index a1be8b473b..da8603176d 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -19,7 +19,7 @@ import DsBinds ( dsBinds, dsInstBinds )
import DsUtils
import Bag ( unionBags )
-import CmdLineOpts ( opt_DoCoreLinting )
+import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
import CoreLift ( liftCoreBindings )
import CoreLint ( lintCoreBindings )
import Id ( nullIdEnv, mkIdEnv )
@@ -52,25 +52,29 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst
(us3, us3a) = splitUniqSupply us2a
(us4, us5) = splitUniqSupply us3a
+ auto_meth = opt_AutoSccsOnAllToplevs
+ auto_top = opt_AutoSccsOnAllToplevs
+ || opt_AutoSccsOnExportedToplevs
+
((core_const_prs, consts_pairs), shadows1)
= initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
consts_env = mkIdEnv consts_pairs
(core_clas_binds, shadows2)
- = initDs us1 consts_env mod_name (dsBinds clas_binds)
+ = initDs us1 consts_env mod_name (dsBinds False clas_binds)
core_clas_prs = pairsFromCoreBinds core_clas_binds
(core_inst_binds, shadows3)
- = initDs us2 consts_env mod_name (dsBinds inst_binds)
+ = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds)
core_inst_prs = pairsFromCoreBinds core_inst_binds
(core_val_binds, shadows4)
- = initDs us3 consts_env mod_name (dsBinds val_binds)
+ = initDs us3 consts_env mod_name (dsBinds auto_top val_binds)
core_val_pairs = pairsFromCoreBinds core_val_binds
(core_recsel_binds, shadows5)
- = initDs us4 consts_env mod_name (dsBinds recsel_binds)
+ = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds)
core_recsel_prs = pairsFromCoreBinds core_recsel_binds
final_binds
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 82380970e7..99cf6d437c 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -29,10 +29,11 @@ import DsGRHSs ( dsGuarded )
import DsUtils
import Match ( matchWrapper )
-import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude )
-import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
-import Id ( idType, DictVar(..), GenId )
+import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_CompilingGhcInternals )
+import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
+import Id ( idType, SYN_IE(DictVar), GenId )
import ListSetOps ( minusList, intersectLists )
+import Name ( isExported )
import PprType ( GenType )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
@@ -60,7 +61,7 @@ that some of the binders are of unboxed type. This is sorted out when
the caller wraps the bindings round an expression.
\begin{code}
-dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
\end{code}
All ``real'' bindings are expressed in terms of the
@@ -96,12 +97,12 @@ But there are lots of special cases.
%==============================================
\begin{code}
-dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
-dsBinds EmptyBinds = returnDs []
-dsBinds (SingleBind bind) = dsBind [] [] id [] bind
+dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith"
+dsBinds auto_scc EmptyBinds = returnDs []
+dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind
-dsBinds (ThenBinds binds_1 binds_2)
- = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
+dsBinds auto_scc (ThenBinds binds_1 binds_2)
+ = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
\end{code}
@@ -130,7 +131,7 @@ definitions, which don't mention the type variables at all, so making them
polymorphic is really overkill. @dsInstBinds@ deals with this case.
\begin{code}
-dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
+dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
= mapDs mk_poly_private_binder private_binders
`thenDs` \ poly_private_binders ->
let
@@ -149,7 +150,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
extendEnvDs inst_env (
- dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
+ dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
))
where
-- "private_binders" is the list of binders in val_binds
@@ -195,7 +196,7 @@ the defn of f' can get floated out, notably if f gets specialised
to a particular type for a.
\begin{code}
-dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
+dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
= -- If there is any non-overloaded polymorphism, make new locals with
-- appropriate polymorphism
(if null non_overloaded_tyvars
@@ -231,7 +232,7 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
extendEnvDs inst_env (
- dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
+ dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
)) `thenDs` \ core_binds ->
let
@@ -358,21 +359,20 @@ dsInstBinds tyvars ((inst, expr) : bs)
-- if profiling, wrap the dict in "_scc_ DICT <dict>":
ds_dict_cc expr
- | not opt_SccProfilingOn ||
- not (isDictTy inst_ty)
+ | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
+ -- the latter is so that -unprof-auto-scc-all adds dict sccs
+ || not (isDictTy inst_ty)
= returnDs expr -- that's easy: do nothing
- | opt_CompilingPrelude
+ | opt_CompilingGhcInternals
= returnDs (SCC prel_dicts_cc expr)
| otherwise
- = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
- -- ToDo: do -dicts-all flag (mark dict things
- -- with individual CCs)
- let
- dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
- in
- returnDs (SCC dict_cc expr)
+ = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
+
+ -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
+
+ returnDs (SCC (mkAllDictsCC mod grp False) expr)
\end{code}
%************************************************************************
@@ -387,22 +387,23 @@ some of the binders are of unboxed type.
For an explanation of the first three args, see @dsMonoBinds@.
\begin{code}
-dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
+dsBind :: Bool -- Add auto sccs to binds
+ -> [TyVar] -> [DictVar] -- Abstract wrt these
-> (Id -> Id) -- Binder substitution
-> [(Id,CoreExpr)] -- Inst bindings already dealt with
-> TypecheckedBind
-> DsM [CoreBinding]
-dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
+dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind
= returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
-dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
- = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
- returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
+dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
+ = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
+ returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
-dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
- = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
- returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
+dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
+ = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
+ returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
\end{code}
@@ -425,7 +426,8 @@ of these binders into applications of the new binder to suitable type variables
and dictionaries.
\begin{code}
-dsMonoBinds :: Bool -- True <=> recursive binding group
+dsMonoBinds :: Bool -- True <=> add auto sccs
+ -> Bool -- True <=> recursive binding group
-> [TyVar] -> [DictVar] -- Abstract wrt these
-> (Id -> Id) -- Binder substitution
-> TypecheckedMonoBinds
@@ -439,11 +441,11 @@ dsMonoBinds :: Bool -- True <=> recursive binding group
%==============================================
\begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
-dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
- = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
- (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
+ = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1)
+ (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2)
\end{code}
@@ -451,45 +453,28 @@ dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
\subsubsection{Simple base cases: function and variable bindings}
%==============================================
-For the simplest bindings, we just heave them in the substitution env:
-
\begin{code}
-{- THESE TWO ARE PLAIN WRONG.
- The extendEnvDs only scopes over the nested call!
- Let the simplifier do this.
-
-dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
- | not (is_rec || isExported was_var)
- = extendEnvDs [(was_var, Var new_var)] (
- returnDs [] )
-
-dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
- | not (isExported was_var)
- = dsExpr expr `thenDs` ( \ core_lit ->
- extendEnvDs [(was_var, core_lit)] (
- returnDs [] ))
--}
-
-dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr)
= dsExpr expr `thenDs` \ core_expr ->
- returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
-\end{code}
+ doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr ->
+ returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
-\begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
= putSrcLocDs locn $
let
new_fun = binder_subst fun
error_string = "function " ++ showForErr fun
in
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
+ doSccAuto auto_scc [fun] body `thenDs` \ sccd_body ->
returnDs [(new_fun,
- mkLam tyvars (dicts ++ args) body)]
+ mkLam tyvars (dicts ++ args) sccd_body)]
-dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
= putSrcLocDs locn $
dsGuarded grhss_and_binds `thenDs` \ body_expr ->
- returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
+ doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr ->
+ returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)]
\end{code}
%==============================================
@@ -503,7 +488,7 @@ be empty. (Simple pattern bindings were handled above.)
First, the paranoia check.
\begin{code}
-dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
+dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
= panic "Non-empty dict list in for pattern binding"
\end{code}
@@ -531,10 +516,11 @@ Then we transform to:
\end{description}
\begin{code}
-dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
+dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
= putSrcLocDs locn $
- dsGuarded grhss_and_binds `thenDs` \ body_expr ->
+ dsGuarded grhss_and_binds `thenDs` \ body_expr ->
+ doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr ->
{- KILLED by Sansom. 95/05
-- make *sure* there are no primitive types in the pattern
@@ -547,11 +533,11 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
-- we can just use the rhs directly
else
-}
--- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
+-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $
mkSelectorBinds tyvars pat
[(binder, binder_subst binder) | binder <- pat_binders]
- body_expr
+ sccd_body_expr
where
pat_binders = collectTypedPatBinders pat
-- NB For a simple tuple pattern, these binders
@@ -565,4 +551,39 @@ extra work to benefit only rather unusual constructs like
\end{verbatim}
Better to extend the whole thing for any irrefutable constructor, at least.
+%************************************************************************
+%* *
+\subsection[doSccAuto]{Adding automatic sccs}
+%* *
+%************************************************************************
+
+\begin{code}
+doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr
+
+doSccAuto False binders core_expr
+ = returnDs core_expr
+
+doSccAuto True [] core_expr -- no binders
+ = returnDs core_expr
+
+doSccAuto True _ core_expr@(SCC _ _) -- already sccd
+ = returnDs core_expr
+doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con
+ = returnDs core_expr
+
+doSccAuto True binders core_expr
+ = let
+ scc_all = opt_AutoSccsOnAllToplevs
+ scc_export = not (null export_binders)
+
+ export_binders = filter isExported binders
+
+ scc_binder = head (if scc_all then binders else export_binders)
+ in
+ if scc_all || scc_export then
+ getModuleAndGroupDs `thenDs` \ (mod,grp) ->
+ returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr)
+ else
+ returnDs core_expr
+\end{code}
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 9ef96010ed..c8644dc893 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -37,7 +37,7 @@ unboxing any boxed primitive arguments and boxing the result if
desired.
The state stuff just consists of adding in
-@\ s -> case s of { S# s# -> ... }@ in an appropriate place.
+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
The unboxing is straightforward, as all information needed to unbox is
available from the type. For each boxed-primitive argument, we
@@ -68,10 +68,10 @@ follows:
\end{verbatim}
\begin{code}
-dsCCall :: FAST_STRING -- C routine to invoke
+dsCCall :: FAST_STRING -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
- -> Bool -- True <=> might cause Haskell GC
- -> Bool -- True <=> really a "_casm_"
+ -> Bool -- True <=> might cause Haskell GC
+ -> Bool -- True <=> really a "_casm_"
-> Type -- Type of the result (a boxed-prim type)
-> DsM CoreExpr
@@ -89,11 +89,9 @@ dsCCall label args may_gc is_asm result_ty
in
mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
let
- the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
+ the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
in
returnDs (Lam (ValBinder old_s) the_body)
- where
- apply f x = f x
\end{code}
\begin{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index d1de63040f..d7b8e68ffd 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -59,7 +59,7 @@ import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon,
charDataCon, charTy
)
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
-import Usage ( UVar(..) )
+import Usage ( SYN_IE(UVar) )
import Util ( zipEqual, pprError, panic, assertPanic )
mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
@@ -269,7 +269,7 @@ dsExpr (ListComp expr quals)
dsListComp core_expr quals
dsExpr (HsLet binds expr)
- = dsBinds binds `thenDs` \ core_binds ->
+ = dsBinds False binds `thenDs` \ core_binds ->
dsExpr expr `thenDs` \ core_expr ->
returnDs ( mkCoLetsAny core_binds core_expr )
@@ -425,7 +425,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds)
dsRbinds rbinds $ \ rbinds' ->
let
record_ty = coreExprType record_expr'
- (tycon, inst_tys, cons) = _trace "DsExpr.getAppDataTyConExpandingDicts" $
+ (tycon, inst_tys, cons) = trace "DsExpr.getAppDataTyConExpandingDicts" $
getAppDataTyConExpandingDicts record_ty
cons_to_upd = filter has_all_fields cons
@@ -657,8 +657,8 @@ dsDo then_id zero_id (stmt:stmts)
VarArg (mkValLam [ignored_result_id] rest)]
LetStmt binds ->
- dsBinds binds `thenDs` \ binds2 ->
- ds_rest `thenDs` \ rest ->
+ dsBinds False binds `thenDs` \ binds2 ->
+ ds_rest `thenDs` \ rest ->
returnDs (mkCoLetsAny binds2 rest)
BindStmtOut pat expr locn a b ->
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index fd8bec3b10..ee11244ec3 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -16,7 +16,7 @@ import HsSyn ( GRHSsAndBinds(..), GRHS(..),
import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
TypecheckedPat(..), TypecheckedHsBinds(..),
TypecheckedHsExpr(..) )
-import CoreSyn ( CoreBinding(..), CoreExpr(..), mkCoLetsAny )
+import CoreSyn ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny )
import DsMonad
import DsUtils
@@ -45,7 +45,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds
-> DsM CoreExpr
dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
- = dsBinds binds `thenDs` \ core_binds ->
+ = dsBinds False binds `thenDs` \ core_binds ->
dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
case can_it_fail of
CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi
index 26a0c4b313..fd329c0c69 100644
--- a/ghc/compiler/deSugar/DsLoop.lhi
+++ b/ghc/compiler/deSugar/DsLoop.lhi
@@ -26,6 +26,6 @@ matchSimply :: CoreExpr -- Scrutinee
-> CoreExpr -- Return this if it does
-> DsM CoreExpr
-dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
\end{code}
diff --git a/ghc/compiler/deSugar/DsLoop_1_3.lhi b/ghc/compiler/deSugar/DsLoop_1_3.lhi
new file mode 100644
index 0000000000..6f115029f3
--- /dev/null
+++ b/ghc/compiler/deSugar/DsLoop_1_3.lhi
@@ -0,0 +1,5 @@
+\begin{code}
+interface DsLoop_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 618f8c910f..a6c8b61934 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -28,11 +28,11 @@ IMP_Ubiq()
import Bag ( emptyBag, snocBag, bagToList )
import CmdLineOpts ( opt_SccGroup )
-import CoreSyn ( CoreExpr(..) )
+import CoreSyn ( SYN_IE(CoreExpr) )
import CoreUtils ( substCoreExpr )
import HsSyn ( OutPat )
import Id ( mkSysLocal, mkIdWithNewUniq,
- lookupIdEnv, growIdEnvList, GenId, IdEnv(..)
+ lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
)
import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
@@ -42,7 +42,7 @@ import TcHsSyn ( TypecheckedPat(..) )
import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instances-} )
import UniqSupply ( splitUniqSupply, getUnique, getUniques,
- mapUs, thenUs, returnUs, UniqSM(..) )
+ mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
import Util ( assoc, mapAccumL, zipWithEqual, panic )
infixr 9 `thenDs`
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 84e871f09c..b5024698cf 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -44,14 +44,14 @@ import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
pprId{-ToDo:rm-},
- DataCon(..), DictVar(..), Id(..), GenId )
+ SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
import TysPrim ( voidTy )
-import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
+import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
--import PprType--ToDo:rm
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index a1d8fc7502..e63d55930e 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -335,7 +335,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = {-_trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
+ (_, inst_tys, _) = {-trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
con_arg_tys' = dataConArgTys con_id inst_tys
tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
@@ -607,7 +607,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
matchWrapper kind [(GRHSMatch
(GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
- = dsBinds binds `thenDs` \ core_binds ->
+ = dsBinds False binds `thenDs` \ core_binds ->
dsExpr expr `thenDs` \ core_expr ->
returnDs ([], mkCoLetsAny core_binds core_expr)
@@ -698,7 +698,7 @@ flattenMatches kind (match : matches)
= flatten_match (pat:pats_so_far) match
flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
- = dsBinds binds `thenDs` \ core_binds ->
+ = dsBinds False binds `thenDs` \ core_binds ->
dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
where
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 8f34cfcdc4..15c5519dbc 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -16,7 +16,7 @@ import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
TypecheckedPat(..)
)
-import CoreSyn ( CoreExpr(..), CoreBinding(..) )
+import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) )
import DsMonad
import DsUtils
View Lorry Controller Status