From ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Wed, 1 May 1996 18:39:38 +0000
Subject: [PATCH] [project @ 1996-05-01 18:36:59 by partain] SLPJ 1.3 changes
through 960501
---
ghc/compiler/HsVersions.h | 70 +------------------------
ghc/compiler/Jmakefile | 2 +-
ghc/compiler/absCSyn/AbsCUtils.lhs | 36 ++-----------
ghc/compiler/absCSyn/PprAbsC.lhs | 51 +++++++++---------
ghc/compiler/basicTypes/Id.lhs | 55 +++++++++----------
ghc/compiler/basicTypes/IdInfo.lhs | 2 +-
ghc/compiler/basicTypes/Name.lhs | 19 -------
ghc/compiler/basicTypes/UniqSupply.lhs | 12 ++---
ghc/compiler/basicTypes/Unique.lhs | 8 +--
ghc/compiler/codeGen/ClosureInfo.lhs | 2 +-
ghc/compiler/coreSyn/PprCore.lhs | 2 +-
ghc/compiler/deSugar/DsUtils.lhs | 4 +-
ghc/compiler/deforest/DefExpr.lhs | 1 -
ghc/compiler/deforest/DefUtils.lhs | 1 -
ghc/compiler/hsSyn/HsMatches.lhs | 2 +-
ghc/compiler/main/CmdLineOpts.lhs | 8 ++-
ghc/compiler/main/Main.lhs | 37 ++++++++-----
ghc/compiler/main/MkIface.lhs | 18 +++++--
ghc/compiler/rename/ParseIface.y | 60 ++++++++++++++-------
ghc/compiler/rename/ParseUtils.lhs | 12 ++++-
ghc/compiler/rename/Rename.lhs | 41 +++++++--------
ghc/compiler/rename/RnBinds.lhs | 10 ++--
ghc/compiler/rename/RnIfaces.lhs | 51 +++++++++++-------
ghc/compiler/rename/RnNames.lhs | 8 +--
ghc/compiler/simplCore/FloatIn.lhs | 10 ++--
ghc/compiler/simplCore/FloatOut.lhs | 2 +-
ghc/compiler/simplCore/SimplCore.lhs | 66 +++++++++--------------
ghc/compiler/simplCore/SmplLoop.lhi | 20 ++++---
ghc/compiler/simplStg/SimplStg.lhs | 22 +++-----
ghc/compiler/stgSyn/StgLint.lhs | 3 +-
ghc/compiler/typecheck/GenSpecEtc.lhs | 3 +-
ghc/compiler/typecheck/Inst.lhs | 2 +-
ghc/compiler/typecheck/TcBinds.lhs | 2 +-
ghc/compiler/typecheck/TcClassDcl.lhs | 2 +-
ghc/compiler/typecheck/TcClassSig.lhs | 2 +-
ghc/compiler/typecheck/TcDefaults.lhs | 2 +-
ghc/compiler/typecheck/TcDeriv.lhs | 6 +--
ghc/compiler/typecheck/TcEnv.lhs | 2 +-
ghc/compiler/typecheck/TcExpr.lhs | 2 +-
ghc/compiler/typecheck/TcGRHSs.lhs | 2 +-
ghc/compiler/typecheck/TcHsSyn.lhs | 2 +-
ghc/compiler/typecheck/TcIfaceSig.lhs | 2 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 4 +-
ghc/compiler/typecheck/TcInstUtil.lhs | 4 +-
ghc/compiler/typecheck/TcKind.lhs | 2 +-
ghc/compiler/typecheck/TcMatches.lhs | 2 +-
ghc/compiler/typecheck/TcModule.lhs | 2 +-
ghc/compiler/typecheck/TcMonoType.lhs | 2 +-
ghc/compiler/typecheck/TcPat.lhs | 2 +-
ghc/compiler/typecheck/TcPragmas.lhs | 4 +-
ghc/compiler/typecheck/TcSimplify.lhs | 2 +-
ghc/compiler/typecheck/TcTyClsDecls.lhs | 2 +-
ghc/compiler/typecheck/TcTyDecls.lhs | 2 +-
ghc/compiler/typecheck/TcType.lhs | 2 +-
ghc/compiler/typecheck/Unify.lhs | 2 +-
ghc/compiler/utils/FiniteMap.lhs | 4 +-
ghc/compiler/utils/ListSetOps.lhs | 24 ++-------
ghc/compiler/utils/Maybes.lhs | 11 ++--
ghc/compiler/utils/Outputable.lhs | 11 ----
ghc/compiler/utils/Util.lhs | 46 +---------------
60 files changed, 315 insertions(+), 477 deletions(-)
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index c5b68ef0b42e..6a01f6858d8a 100644
--- a/ghc/compiler/HsVersions.h
+++ b/ghc/compiler/HsVersions.h
@@ -10,10 +10,6 @@ you will screw up the layout where they are used in case expressions!
#endif
-#define MkInt I#
-#define MkChar C#
-#define MkArray _Array
-
#ifdef __GLASGOW_HASKELL__
#define TAG_ Int#
#define LT_ -1#
@@ -22,58 +18,14 @@ you will screw up the layout where they are used in case expressions!
#endif
#define GT__ _
-#ifdef __HBC__
-#define IMPORT_Trace import Trace
-#define BSCC(l) (
-#define ESCC )
-#else
-#define IMPORT_Trace {--}
-#define BSCC(l) (_scc_ l (
-#define ESCC ))
-#endif
-
--- these are overridable
-#ifndef BIND
-#define BIND case
-#endif /* BIND */
-#ifndef _TO_
-#define _TO_ of {
-#endif /* _TO_ */
-#ifndef BEND
-#define BEND }
-#endif /* BEND */
-#ifndef RETN
-#define RETN {--}
-#endif /* RETN */
-#ifndef RETN_TYPE
-#define RETN_TYPE {--}
-#endif /* RETN_TYPE */
-
#define COMMA ,
#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
-#define CHK_Ubiq() import Ubiq
#else
#define ASSERT(e)
-#define CHK_Ubiq()
-#endif
-
--- ToDo: ghci needs to load far too many bits of the backend because
--- this ATTACK_PRAGMA stuff encourages Utils.lhs to tell
--- everyone about everyone else. I guess we need to add some
--- more conditional stuff in.
-#ifdef USE_ATTACK_PRAGMAS
-#define IF_ATTACK_PRAGMAS(x) x
-#else
-#define IF_ATTACK_PRAGMAS(x) {--}
-#endif
-
-#if GHCI
-#define IF_GHCI(stuff) stuff
-#else
-#define IF_GHCI(stuff) {-nothing-}
#endif
+#define CHK_Ubiq() import Ubiq
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26
#define trace _trace
@@ -157,24 +109,4 @@ you will screw up the layout where they are used in case expressions!
#define _CONCAT_ concat
#endif
-#if __HASKELL1__ < 3
-{- To avoid confusion with Haskell 1.3, we use Swahili.
-
- data Maybe a = Nothing | Just a
- data Labda a = Hamna | Ni a
-
- Should we ever need to increase confusion with HBC, we will
- use Swedish:
-
- data Kanske a = Ingenting | Bara a
--}
-# define Maybe Labda
-# define Just Ni
-# define Nothing Hamna
-#else
-# define MAYBE Labda
-# define JUST Ni
-# define NOTHING Hamna
-#endif
-
#endif
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index c54b9b5108db..373757ff2562 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -377,7 +377,7 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
#endif
#if GhcWithHscOptimised == YES
-#define __version_sensitive_flags -DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs -fomit-reexported-instances -fshow-import-specs
+#define __version_sensitive_flags -O /*-DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs*/ -fomit-reexported-instances -fshow-import-specs
#else
#define __version_sensitive_flags -fomit-reexported-instances
#endif
diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index e25ce5d5ae09..a074524793a7 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -66,39 +66,14 @@ mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
mkAbsCStmts = AbsCStmts
{- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
- = BIND (case (nonemptyAbsC abc2) of
+ = case (case (nonemptyAbsC abc2) of
Nothing -> AbsCNop
- Just d2 -> d2) _TO_ abc2b ->
+ Just d2 -> d2) of { abc2b ->
case (nonemptyAbsC abc1) of {
Nothing -> abc2b;
Just d1 -> AbsCStmts d1 abc2b
- } BEND
--}
-{-
- = case (nonemptyAbsC abc1) of
- Nothing -> abc2
- Just d1 -> AbsCStmts d1 abc2
--}
-{- old2:
- = case (nonemptyAbsC abc1) of
- Nothing -> case (nonemptyAbsC abc2) of
- Nothing -> AbsCNop
- Just d2 -> d2
- Just d1 -> AbsCStmts d1 abc2
--}
-{- old:
- if abc1_empty then
- if abc2_empty
- then AbsCNop
- else abc2
- else if {- abc1 not empty but -} abc2_empty then
- abc1
- else {- neither empty -}
- AbsCStmts abc1 abc2
- where
- abc1_empty = noAbsCcode abc1
- abc2_empty = noAbsCcode abc2
+ } }
-}
\end{code}
@@ -539,14 +514,13 @@ flatAmode (CCode abs_C)
_ ->
-- de-anonymous-ise the code and push it (labelled) to the top level
getUniqFlt `thenFlt` \ new_uniq ->
- BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label ->
+ case (mkReturnPtLabel new_uniq) of { return_pt_label ->
flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
returnFlt (
CLbl return_pt_label CodePtrRep,
tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
-- DO NOT TOUCH the stuff sent to the top...
- )
- BEND
+ ) }
flatAmode (CTableEntry base index kind)
= flatAmode base `thenFlt` \ (base_amode, base_tops) ->
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index d763bc70ccaa..9247568401cc 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -210,7 +210,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
the_op = ppr_op_call non_void_results non_void_args
-- liveness mask is *in* the non_void_args
in
- BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) ->
+ case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
uppAboves [ pp_saves,
the_op,
@@ -218,7 +218,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
]
else
the_op
- BEND
+ }
where
ppr_op_call results args
= uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
@@ -246,7 +246,7 @@ pprAbsC sty stmt@(CCallProfCCMacro op as) _
pprAbsC sty (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
- BIND (pprTempAndExternDecls abs_C) _TO_ (pp_temps, pp_exts) ->
+ case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
uppAboves [
uppBesides [uppStr (if (externallyVisibleCLabel label)
then "FN_(" -- abbreviations to save on output
@@ -259,7 +259,7 @@ pprAbsC sty (CCodeBlock label abs_C) _
uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
uppNest 8 (uppPStr SLIT("FE_")),
uppChar '}' ]
- BEND
+ }
pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
= uppBesides [ pp_init_hdr, uppStr "_HDR(",
@@ -279,7 +279,7 @@ pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
getSMInitHdrStr sm_rep)
pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
- = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
+ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
uppAboves [
case sty of
PprForC -> pp_exts
@@ -296,7 +296,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
uppStr "};" ]
- BEND
+ }
where
info_lbl = infoTableLabelFromCI cl_info
@@ -309,9 +309,8 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
if not (closureUpdReqd cl_info) then
[]
else
- BIND (max 0 (mIN_UPD_SIZE - length amodes)) _TO_ still_needed ->
- nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
- BEND
+ case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+ nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
{-
STATIC_INIT_HDR(c,i,localness) blows into:
@@ -420,7 +419,7 @@ pprAbsC sty stmt@(CRetUnVector label amode) _
pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
pprAbsC sty stmt@(CFlatRetVector label amodes) _
- = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
+ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
uppAboves [
case sty of
PprForC -> pp_exts
@@ -428,8 +427,7 @@ pprAbsC sty stmt@(CFlatRetVector label amodes) _
uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
pprCLabel sty label, uppStr "[] = {"],
uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
- uppStr "};" ]
- BEND
+ uppStr "};" ] }
where
ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
@@ -444,12 +442,12 @@ ppLocalness label
const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
ppLocalnessMacro for_fun{-vs data-} clabel
- = BIND (if externallyVisibleCLabel clabel then "E" else "I") _TO_ prefix ->
- BIND (if isReadOnly clabel then "RO_" else "") _TO_ suffix ->
+ = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix ->
+ case (if isReadOnly clabel then "RO_" else "") of { suffix ->
if for_fun
then uppStr (prefix ++ "F_")
else uppStr (prefix ++ "D_" ++ suffix)
- BEND BEND
+ } }
\end{code}
\begin{code}
@@ -1109,10 +1107,9 @@ pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
= initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
- BIND (catMaybes [t_p1, t_p2]) _TO_ real_temps ->
- BIND (catMaybes [e_p1, e_p2]) _TO_ real_exts ->
- returnTE (uppAboves real_temps, uppAboves real_exts)
- BEND BEND
+ case (catMaybes [t_p1, t_p2]) of { real_temps ->
+ case (catMaybes [e_p1, e_p2]) of { real_exts ->
+ returnTE (uppAboves real_temps, uppAboves real_exts) }}
)
pprTempAndExternDecls other_stmt
@@ -1214,14 +1211,14 @@ pprExternDecl clabel kind
= if not (needsCDecl clabel) then
uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
else
- BIND (
+ case (
case kind of
CodePtrRep -> ppLocalnessMacro True{-function-} clabel
- _ -> ppLocalnessMacro False{-data-} clabel
- ) _TO_ pp_macro_str ->
+ _ -> ppLocalnessMacro False{-data-} clabel
+ ) of { pp_macro_str ->
uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
- BEND
+ }
\end{code}
\begin{code}
@@ -1385,12 +1382,12 @@ ppr_decls_Amode other = returnTE (Nothing, Nothing)
maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
maybe_uppAboves ps
- = BIND (unzip ps) _TO_ (ts, es) ->
- BIND (catMaybes ts) _TO_ real_ts ->
- BIND (catMaybes es) _TO_ real_es ->
+ = case (unzip ps) of { (ts, es) ->
+ case (catMaybes ts) of { real_ts ->
+ case (catMaybes es) of { real_es ->
(if (null real_ts) then Nothing else Just (uppAboves real_ts),
if (null real_es) then Nothing else Just (uppAboves real_es))
- BEND BEND BEND
+ } } }
\end{code}
\begin{code}
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 977bf8806392..152b9f3e51ec 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -116,7 +116,7 @@ import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
- nmbrType, addTyVar,
+ nmbrType, nmbrTyVar,
GenType, GenTyVar
)
import PprStyle
@@ -1098,11 +1098,10 @@ getIdNamePieces show_uniqs id
get_fullname_pieces :: Name -> [FAST_STRING]
get_fullname_pieces n
- = BIND (moduleNamePair n) _TO_ (mod, name) ->
+ = case (moduleNamePair n) of { (mod, name) ->
if isPreludeDefinedName n
then [name]
- else [mod, name]
- BEND
+ else [mod, name] }
\end{code}
%************************************************************************
@@ -1375,11 +1374,11 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon
(tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
tyvar_tys = mkTyVarTys tyvars
in
- BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
+ case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
mkUnfolding EssentialUnfolding -- for data constructors
(mkLam tyvars (dict_vars ++ vars) plain_Con)
- BEND
+ }
mk_uf_bits tvs ctxt arg_tys tycon
= let
@@ -1390,19 +1389,19 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
-- instead.
- BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
- _TO_ inst_dict_tys ->
- BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
+ case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
+ of { inst_dict_tys ->
+ case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
-- We can only have **ONE** call to mkTemplateLocals here;
-- otherwise, we get two blobs of locals w/ mixed-up Uniques
-- (Mega-Sigh) [ToDo]
- BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
+ case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
- BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
+ case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
(tyvars, dict_vars, vars)
- BEND BEND BEND BEND
+ }}}}
where
-- these are really dubious Types, but they are only to make the
-- binders for the lambdas for tossed-away dicts.
@@ -1439,17 +1438,14 @@ mkTupleCon arity
(tyvars, dict_vars, vars) = mk_uf_bits arity
tyvar_tys = mkTyVarTys tyvars
in
- BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
-
+ case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
mkUnfolding
EssentialUnfolding -- data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con)
- BEND
+ (mkLam tyvars (dict_vars ++ vars) plain_Con) }
mk_uf_bits arity
- = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
- (tyvars, [], vars)
- BEND
+ = case (mkTemplateLocals tyvar_tys) of { vars ->
+ (tyvars, [], vars) }
where
tyvar_tmpls = take arity alphaTyVars
(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
@@ -1824,35 +1820,32 @@ instance NamedThing (GenId ty) where
mod -> (mod, classOpString op)
get (SpecId unspec ty_maybes _)
- = BIND moduleNamePair unspec _TO_ (mod, unspec_nm) ->
- BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
+ = case moduleNamePair unspec of { (mod, unspec_nm) ->
+ case specMaybeTysSuffix ty_maybes of { tys_suffix ->
(mod,
unspec_nm _APPEND_
(if not (toplevelishId unspec)
then showUnique u
else tys_suffix)
- )
- BEND BEND
+ ) }}
get (WorkerId unwrkr)
- = BIND moduleNamePair unwrkr _TO_ (mod, unwrkr_nm) ->
+ = case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
(mod,
unwrkr_nm _APPEND_
(if not (toplevelishId unwrkr)
then showUnique u
else SLIT(".wrk"))
- )
- BEND
+ ) }
get other_details
-- the remaining internally-generated flavours of
-- Ids really do not have meaningful "original name" stuff,
-- but we need to make up something (usually for debugging output)
- = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
- BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
- (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
- BEND BEND
+ = case (getIdNamePieces True this_id) of { (piece1:pieces) ->
+ case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
+ (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
-}
\end{code}
@@ -1989,7 +1982,7 @@ nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
nmbr_details :: IdDetails -> NmbrM IdDetails
nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
- = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
+ = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 1a65a676b26c..90f81a8894b3 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -728,7 +728,7 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
\begin{code}
mkUnfolding guide expr
= GenForm False (mkFormSummary NoStrictnessInfo expr)
- (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
+ (occurAnalyseGlobalExpr expr)
guide
\end{code}
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 2a44651a5dd9..fcb4ecfcf021 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -350,12 +350,6 @@ exportFlagOn NotExported = False
exportFlagOn _ = True
isExported a = exportFlagOn (getExportFlag a)
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-#endif
\end{code}
%************************************************************************
@@ -409,12 +403,6 @@ comparison.]
\begin{code}
a `ltLexical` b = origName a < origName b
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
-{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
-{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
-#endif
\end{code}
These functions test strings to see if they fit the lexical categories
@@ -502,11 +490,4 @@ pprNonSym sty var
= if isSymLexeme var
then ppParens (ppr sty var)
else ppr sty var
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isSymLexeme :: Id -> Bool #-}
-{-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-}
-{-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-}
-{-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-}
-#endif
\end{code}
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index 7c155f326cc4..bc6da1645fd6 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -67,7 +67,7 @@ getUniques :: Int -> UniqSupply -> [Unique]
\end{code}
\begin{code}
-mkSplitUniqSupply (MkChar c#)
+mkSplitUniqSupply (C# c#)
= let
mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
@@ -91,7 +91,7 @@ mkSplitUniqSupply (MkChar c#)
(r, s)
mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
- returnPrimIO (MkInt (w2i (mask# `or#` u#)))
+ returnPrimIO (I# (w2i (mask# `or#` u#)))
in
mk_supply# `thenPrimIO` \ s ->
return s
@@ -100,13 +100,13 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
\end{code}
\begin{code}
-getUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
+getUnique (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
-getUniques i@(MkInt i#) supply = i# `get_from` supply
+getUniques (I# i) supply = i `get_from` supply
where
get_from 0# _ = []
- get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
- = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
+ get_from n (MkSplitUniqSupply (I# u) _ s2)
+ = mkUniqueGrimily u : get_from (n `minusInt#` 1#) s2
\end{code}
%************************************************************************
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 36702cc90530..54c78983a409 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -252,13 +252,13 @@ w2i x = word2Int# x
i2w x = int2Word# x
i2w_s x = (x::Int#)
-mkUnique (MkChar c#) (MkInt i#)
- = MkUnique (w2i (((i2w (ord# c#)) `shiftL#` (i2w_s 24#)) `or#` (i2w i#)))
+mkUnique (C# c) (I# i)
+ = MkUnique (w2i (((i2w (ord# c)) `shiftL#` (i2w_s 24#)) `or#` (i2w i)))
unpkUnique (MkUnique u)
= let
- tag = MkChar (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
- i = MkInt (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
+ tag = C# (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
+ i = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
in
(tag, i)
where
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index ae7cf40f2cee..9e08f64b13c7 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -25,7 +25,7 @@ module ClosureInfo (
layOutDynClosure, layOutDynCon, layOutStaticClosure,
layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index ed00cac62020..20f0b4d1c168 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -17,7 +17,7 @@ module PprCore (
pprTypedCoreBinder
-- these are here to make the instances go in 0.26:
-#if __GLASGOW_HASKELL__ <= 26
+#if __GLASGOW_HASKELL__ <= 30
, GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
, GenCoreCaseDefault, GenCoreArg
#endif
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index c4a46e2e3d2c..411a7c1bdb12 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -54,7 +54,7 @@ import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
-import PprType--ToDo:rm
+--import PprType--ToDo:rm
import Pretty--ToDo:rm
import TyVar--ToDo:rm
import Unique--ToDo:rm
@@ -422,7 +422,7 @@ The general case:
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
- = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
+ = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs
index 229937164047..cda10ffd639f 100644
--- a/ghc/compiler/deforest/DefExpr.lhs
+++ b/ghc/compiler/deforest/DefExpr.lhs
@@ -18,7 +18,6 @@
> import Type ( applyTypeEnvToTy, isPrimType,
> SigmaType(..), Type
-> IF_ATTACK_PRAGMAS(COMMA cmpUniType)
> )
> import CmdLineOpts ( SwitchResult, switchIsOn )
> import CoreUnfold ( UnfoldingDetails(..) )
diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs
index 2a8edc9b501c..9e53ae0ef84b 100644
--- a/ghc/compiler/deforest/DefUtils.lhs
+++ b/ghc/compiler/deforest/DefUtils.lhs
@@ -22,7 +22,6 @@
> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
> tyVarsOfType, TyVar, SigmaType(..)
-> IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
> )
> import Literal ( Literal ) -- for Eq Literal
> import CoreSyn
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index 3b202f4fea0f..7c7db36de986 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -14,7 +14,7 @@ import Ubiq{-uitous-}
import HsLoop ( HsExpr, nullBinds, HsBinds )
import Outputable ( ifPprShowAll )
-import PprType
+import PprType ( GenType{-instance Outputable-} )
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
import Util ( panic )
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 8bbfa55c1120..81919132f44b 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -221,10 +221,9 @@ opt_AsmTarget = lookup_str "-fasm="
opt_SccGroup = lookup_str "-G="
opt_ProduceC = lookup_str "-C="
opt_ProduceS = lookup_str "-S="
-opt_ProduceHi = lookup_str "-hifile="
-opt_ProduceHu = lookup_str "-hufile="
-opt_MyHi = lookup_str "-myhifile=" -- the ones produced last time
-opt_MyHu = lookup_str "-myhufile=" -- for this module
+opt_MustRecompile = lookup SLIT("-fmust-recompile")
+opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time
+opt_MyHi = lookup_str "-myhifile=" -- the one produced last time
opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names="
opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold"
@@ -234,7 +233,6 @@ opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold"
opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude")
opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas")
-opt_HuSuffix = case (lookup_str "-husuffix=") of { Nothing -> ".hu" ; Just x -> x }
opt_HiSuffix = case (lookup_str "-hisuffix=") of { Nothing -> ".hi" ; Just x -> x }
opt_SysHiSuffix = case (lookup_str "-syshisuffix=") of { Nothing -> ".hi" ; Just x -> x }
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 235fb4ada8a2..49c9b6999225 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -33,7 +33,6 @@ import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
import ErrUtils ( pprBagOfErrors, ghcExit )
import Maybes ( maybeToBool, MaybeErr(..) )
-import PrelInfo ( builtinNameInfo )
import RdrHsSyn ( getRawExportees )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
@@ -70,6 +69,7 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* READER
show_pass "Reader" >>
+ _scc_ "Reader"
rdModule >>= \ (mod_name, rdr_module) ->
doDump opt_D_dump_rdr "Reader:"
@@ -79,24 +79,22 @@ doIt (core_cmds, stg_cmds) input_pgm
(pp_show (ppSourceStats rdr_module)) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
- mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
- mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker
- mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
- mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier
- mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
- mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
- mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
+ mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
+ mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker
+ mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
+ mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier
+ mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
+ mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
+ mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
-- ******* RENAMER
show_pass "Renamer" >>
+ _scc_ "Renamer"
- case builtinNameInfo
- of { (wiredin_fm, key_fm, idinfo_fm) ->
-
- renameModule wiredin_fm key_fm rn_uniqs rdr_module >>=
+ renameModule rn_uniqs rdr_module >>=
\ (rn_mod, rn_env, import_names,
- version_info, instance_modules,
+ usage_stuff,
rn_errs_bag, rn_warns_bag) ->
if (not (isEmptyBag rn_errs_bag)) then
@@ -122,7 +120,11 @@ doIt (core_cmds, stg_cmds) input_pgm
-- (the iface file is produced incrementally, as we have
-- the information that we need...; we use "iface<blah>")
-- "endIface" finishes the job.
+ let
+ (usages_map, version_info, instance_modules) = usage_stuff
+ in
startIface mod_name >>= \ if_handle ->
+ ifaceUsages if_handle usages_map >>
ifaceVersions if_handle version_info >>
ifaceExportList if_handle rn_mod >>
ifaceFixities if_handle rn_mod >>
@@ -130,6 +132,7 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* TYPECHECKER
show_pass "TypeCheck" >>
+ _scc_ "TypeCheck"
case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
@@ -176,6 +179,7 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* DESUGARER
show_pass "DeSugar" >>
+ _scc_ "DeSugar"
let
(desugared,ds_warnings)
= deSugar ds_uniqs mod_name typechecked_quint
@@ -192,6 +196,8 @@ doIt (core_cmds, stg_cmds) input_pgm
>>
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
+ show_pass "Core2Core" >>
+ _scc_ "Core2Core"
core2core core_cmds mod_name pprStyle
sm_uniqs local_tycons pragma_tycon_specs desugared
>>=
@@ -205,11 +211,13 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* STG-TO-STG SIMPLIFICATION
show_pass "Core2Stg" >>
+ _scc_ "Core2Stg"
let
stg_binds = topCoreBindsToStg c2s_uniqs simplified
in
show_pass "Stg2Stg" >>
+ _scc_ "Stg2Stg"
stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds
>>=
@@ -225,6 +233,7 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
show_pass "CodeGen" >>
+ _scc_ "CodeGen"
let
abstractC = codeGen mod_name -- module name for CC labelling
cost_centre_info
@@ -272,7 +281,7 @@ doIt (core_cmds, stg_cmds) input_pgm
doOutput opt_ProduceC c_output_w >>
ghcExit 0
- } ) } }
+ } ) }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index aee025fa1e7b..489183777ac3 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -8,6 +8,7 @@
module MkIface (
startIface, endIface,
+ ifaceUsages,
ifaceVersions,
ifaceExportList,
ifaceFixities,
@@ -35,12 +36,12 @@ import Name ( nameOrigName, origName, nameOf,
RdrName(..){-instance Outputable-},
Name{-instance NamedThing-}
)
+import ParseUtils ( UsagesMap(..), VersionsMap(..) )
import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
import PprType -- most of it (??)
import Pretty -- quite a bit
import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
-import RnIfaces ( VersionInfo(..) )
import TcModule ( TcIfaceInfo(..) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
@@ -78,9 +79,13 @@ to the handle provided by @startIface@.
startIface :: Module
-> IO (Maybe Handle) -- Nothing <=> don't do an interface
endIface :: Maybe Handle -> IO ()
+ifaceUsages
+ :: Maybe Handle
+ -> UsagesMap
+ -> IO ()
ifaceVersions
:: Maybe Handle
- -> VersionInfo
+ -> VersionsMap
-> IO ()
ifaceExportList
:: Maybe Handle
@@ -120,11 +125,18 @@ endIface Nothing = return ()
endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
\end{code}
+\begin{code}
+ifaceUsages Nothing{-no iface handle-} _ = return ()
+
+ifaceUsages (Just if_hdl) version_info
+ = hPutStr if_hdl "__usages__\nFoo 1" -- a stub, obviously
+\end{code}
+
\begin{code}
ifaceVersions Nothing{-no iface handle-} _ = return ()
ifaceVersions (Just if_hdl) version_info
- = hPutStr if_hdl "__versions__\nFoo(1)" -- a stub, obviously
+ = hPutStr if_hdl "\n__versions__\nFoo 1" -- a stub, obviously
\end{code}
\begin{code}
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index ee43188cffee..790b802bfda8 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -34,6 +34,7 @@ parseIface = parseIToks . lexIface
%token
INTERFACE { ITinterface }
+ USAGES_PART { ITusages }
VERSIONS_PART { ITversions }
EXPORTS_PART { ITexports }
INSTANCE_MODULES_PART { ITinstance_modules }
@@ -79,31 +80,51 @@ parseIface = parseIToks . lexIface
iface :: { ParsedIface }
iface : INTERFACE CONID INTEGER
- versions_part exports_part inst_modules_part
+ usages_part versions_part
+ exports_part inst_modules_part
fixities_part decls_part instances_part pragmas_part
- { case $8 of { (tm, vm) ->
+ { case $9 of { (tm, vm) ->
ParsedIface $2 (fromInteger $3) Nothing{-src version-}
- $4 -- local versions
- $5 -- exports map
- $6 -- instance modules
- $7 -- fixities map
+ $4 -- usages
+ $5 -- local versions
+ $6 -- exports map
+ $7 -- instance modules
+ $8 -- fixities map
tm -- decls maps
vm
- $9 -- local instances
- $10 -- pragmas map
+ $10 -- local instances
+ $11 -- pragmas map
}
--------------------------------------------------------------------------
}
-versions_part :: { LocalVersionsMap }
-versions_part : VERSIONS_PART name_version_pairs
- { bagToFM $2 }
+usages_part :: { UsagesMap }
+usages_part : USAGES_PART module_stuff_pairs { bagToFM $2 }
+ | { emptyFM }
+
+versions_part :: { VersionsMap }
+versions_part : VERSIONS_PART name_version_pairs { bagToFM $2 }
+ | { emptyFM }
+
+module_stuff_pairs :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) }
+module_stuff_pairs : module_stuff_pair
+ { unitBag $1 }
+ | module_stuff_pairs module_stuff_pair
+ { $1 `snocBag` $2 }
+
+module_stuff_pair :: { (Module, (Version, FiniteMap FAST_STRING Version)) }
+module_stuff_pair : CONID INTEGER DCOLON name_version_pairs SEMI
+ { ($1, (fromInteger $2, bagToFM $4)) }
name_version_pairs :: { Bag (FAST_STRING, Int) }
-name_version_pairs : iname OPAREN INTEGER CPAREN
- { unitBag ($1, fromInteger $3) }
- | name_version_pairs iname OPAREN INTEGER CPAREN
- { $1 `snocBag` ($2, fromInteger $4)
+name_version_pairs : name_version_pair
+ { unitBag $1 }
+ | name_version_pairs COMMA name_version_pair
+ { $1 `snocBag` $3 }
+
+name_version_pair :: { (FAST_STRING, Int) }
+name_version_pair : iname INTEGER
+ { ($1, fromInteger $2)
--------------------------------------------------------------------------
}
@@ -111,10 +132,11 @@ exports_part :: { ExportsMap }
exports_part : EXPORTS_PART export_items { bagToFM $2 }
export_items :: { Bag (FAST_STRING, (RdrName, ExportFlag)) }
-export_items : qiname maybe_dotdot
- { unitBag (de_qual $1, ($1, $2)) }
- | export_items qiname maybe_dotdot
- { $1 `snocBag` (de_qual $2, ($2, $3)) }
+export_items : export_item { unitBag $1 }
+ | export_items export_item { $1 `snocBag` $2 }
+
+export_item :: { (FAST_STRING, (RdrName, ExportFlag)) }
+export_item : qiname maybe_dotdot { (de_qual $1, ($1, $2)) }
maybe_dotdot :: { ExportFlag }
maybe_dotdot : DOTDOT { ExportAll }
diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs
index 6701b7a3f44b..32837945149e 100644
--- a/ghc/compiler/rename/ParseUtils.lhs
+++ b/ghc/compiler/rename/ParseUtils.lhs
@@ -31,7 +31,12 @@ import Util ( startsWith, isIn, panic, assertPanic )
\end{code}
\begin{code}
-type LocalVersionsMap = FiniteMap FAST_STRING Version
+type UsagesMap = FiniteMap Module (Version, VersionsMap)
+ -- module => its version, then to all its entities
+ -- and their versions; "instance" is a magic entity
+ -- representing all the instances def'd in that module
+type VersionsMap = FiniteMap FAST_STRING Version
+ -- Versions for things def'd in this module
type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag)
type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl
type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
@@ -45,7 +50,8 @@ data ParsedIface
Module -- Module name
Version -- Module version number
(Maybe Version) -- Source version number
- LocalVersionsMap -- Local version numbers
+ UsagesMap -- Used when compiling this module
+ VersionsMap -- Version numbers of things from this module
ExportsMap -- Exported names
(Bag Module) -- Special instance modules
FixitiesMap -- fixities of local things
@@ -71,6 +77,7 @@ data RdrIfaceInst
-----------------------------------------------------------------
data IfaceToken
= ITinterface -- keywords
+ | ITusages
| ITversions
| ITexports
| ITinstance_modules
@@ -330,6 +337,7 @@ lexIface str
keywordsFM = listToFM [
("interface", ITinterface)
+ ,("__usages__", ITusages)
,("__versions__", ITversions)
,("__exports__", ITexports)
,("__instance_modules__",ITinstance_modules)
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index c5b881ac6fd3..4751fef5a0fe 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -26,11 +26,13 @@ import Pretty
import FiniteMap
import Util (pprPanic, pprTrace)
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
+import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
+ UsagesMap(..), VersionsMap(..)
+ )
import RnMonad
import RnNames ( getGlobalNames, GlobalNameInfo(..) )
import RnSource ( rnSource )
-import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) )
+import RnIfaces ( findHiFiles, rnIfaces )
import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
@@ -39,7 +41,7 @@ import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
import Maybes ( catMaybes )
import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
-import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
+import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
import PrelMods ( pRELUDE )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
@@ -47,17 +49,16 @@ import Util ( panic, assertPanic )
\end{code}
\begin{code}
-renameModule :: BuiltinNames
- -> BuiltinKeys
- -> UniqSupply
+renameModule :: UniqSupply
-> RdrNameHsModule
-> IO (RenamedHsModule, -- output, after renaming
RnEnv, -- final env (for renaming derivings)
[Module], -- imported modules; for profiling
- VersionInfo, -- version info; for usage
- [Module], -- instance modules; for iface
+ (UsagesMap,
+ VersionsMap, -- version info; for usage
+ [Module]), -- instance modules; for iface
Bag Error,
Bag Warning)
@@ -68,10 +69,12 @@ ToDo: Builtin names which must be read.
ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
-renameModule b_names b_keys us
- input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
+renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
- = --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
+ = let
+ (b_names, b_keys, _) = builtinNameInfo
+ in
+ --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
-- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
-- , ppCat (map ppPStr (keysFM builtin_tcs))
-- , ppCat (map ppPStr (keysFM b_keys))
@@ -128,7 +131,7 @@ renameModule b_names b_keys us
}) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
if not (isEmptyBag errs_so_far) then
- return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
+ return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
else
-- No errors renaming source so rename the interfaces ...
@@ -175,19 +178,13 @@ renameModule b_names b_keys us
rn_module (must_haves ++ imports_used) >>=
\ (rn_module_with_imports, final_env,
(implicit_val_fm, implicit_tc_fm),
+ usage_stuff,
(iface_errs, iface_warns)) ->
- let
- all_imports_used = imports_used ++ eltsFM implicit_tc_fm
- ++ eltsFM implicit_val_fm
- in
- finalIfaceInfo iface_cache all_imports_used imp_mods >>=
- \ (version_info, instance_mods) ->
return (rn_module_with_imports,
final_env,
imp_mods,
- version_info,
- instance_mods,
+ usage_stuff,
errs_so_far `unionBags` iface_errs,
warns_so_far `unionBags` iface_warns)
where
@@ -198,7 +195,8 @@ renameModule b_names b_keys us
\end{code}
\begin{code}
-pprPIface (ParsedIface m v mv lcm exm ims lfx ltdm lvdm lids ldp)
+{- TESTING:
+pprPIface (ParsedIface m v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
= ppAboves [
ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
case mv of { Nothing -> ppNil; Just n -> ppInt n }],
@@ -258,4 +256,5 @@ pprRdrIfaceDecl (ValSig f _ ty)
pprRdrInstDecl (InstSig c t _ decl)
= ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
ppr PprDebug decl]
+-}
\end{code}
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 8e5cf9a11bc4..3c27d75f93ca 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -410,12 +410,12 @@ reconstructRec cycles edges mbi
reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
reconstructCycle mbi2 cycle
- = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
- _TO_ relevant_binds_and_sigs ->
+ = case [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
+ of { relevant_binds_and_sigs ->
- BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
+ case (unzip relevant_binds_and_sigs) of { (binds, sig_lists) ->
- BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
+ case (foldr AndMonoBinds EmptyMonoBinds binds) of { this_gp_binds ->
let
this_gp_sigs = foldr1 (++) sig_lists
have_sigs = not (null sig_lists)
@@ -424,7 +424,7 @@ reconstructRec cycles edges mbi
-- e.g. "have_sigs [[], [], []]" ???????????
in
mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
- BEND BEND BEND
+ }}}
where
is_elem = isIn "reconstructRec"
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 01dc045d2592..d2f62e42734e 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -12,9 +12,7 @@ module RnIfaces (
cachedDecl,
readIface,
rnIfaces,
- finalIfaceInfo,
- IfaceCache(..),
- VersionInfo(..)
+ IfaceCache(..)
) where
import Ubiq
@@ -31,13 +29,16 @@ import RnMonad
import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
import ParseIface ( parseIface )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
+import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
+ VersionsMap(..), UsagesMap(..)
+ )
import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
- fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} )
+ fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-}
+ )
import Maybes ( maybeToBool )
import Name ( moduleNamePair, origName, isRdrLexCon,
RdrName(..){-instance NamedThing-}
@@ -182,7 +183,7 @@ cachedDecl iface_cache class_or_tycon orig
= cachedIface iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
Failed err -> return (Failed err)
- Succeeded (ParsedIface _ _ _ _ exps _ _ tdefs vdefs _ _) ->
+ Succeeded (ParsedIface _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
Just decl -> return (Succeeded decl)
Nothing -> return (Failed (noDeclInIfaceErr mod str))
@@ -275,6 +276,7 @@ rnIfaces :: IfaceCache -- iface cache (mutvar)
-> IO (RenamedHsModule, -- extended module
RnEnv, -- final env (for renaming derivings)
ImplicitEnv, -- implicit names used (for usage info)
+ (UsagesMap,VersionsMap,[Module]), -- usage info
(Bag Error, Bag Warning))
rnIfaces iface_cache imp_mods us
@@ -287,14 +289,14 @@ rnIfaces iface_cache imp_mods us
= {-
pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
- pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $
+ pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
- pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $
+ pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
- pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dqual]) $
+ pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $
- pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $
+ pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
-}
@@ -306,6 +308,11 @@ rnIfaces iface_cache imp_mods us
if_errs_warns),
if_final_env) ->
+ -- finalize what we want to say we learned about the
+ -- things we used
+ finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
+ \ usage_stuff@(usage_info, version_info, instance_mods) ->
+
return (HsModule modname iface_version exports imports fixities
(typedecls ++ if_typedecls)
typesigs
@@ -316,6 +323,7 @@ rnIfaces iface_cache imp_mods us
src_loc,
if_final_env,
if_implicits,
+ usage_stuff,
if_errs_warns)
where
decls_and_insts todo def_env occ_env to_return us
@@ -571,7 +579,7 @@ cacheInstModules iface_cache imp_mods
let
imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
- get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims
+ get_ims (ParsedIface _ _ _ _ _ _ ims _ _ _ _ _) = ims
in
accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces ->
@@ -651,7 +659,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
}
where
- get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts
+ get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ insts _) = insts
add_done_inst (InstSig clas tycon _ _) inst_env
= addToFM_C (+) inst_env (tycon,clas) 1
@@ -700,15 +708,22 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
\begin{code}
finalIfaceInfo ::
IfaceCache -- iface cache
- -> [RnName] -- all imported names required
- -> [Module] -- directly imported modules
- -> IO (VersionInfo, -- info about version numbers
+ -> RnEnv
+ -> [RenamedInstDecl]
+-- -> [RnName] -- all imported names required
+-- -> [Module] -- directly imported modules
+ -> IO (UsagesMap,
+ VersionsMap, -- info about version numbers
[Module]) -- special instance modules
-type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])]
+finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
+ =
+ pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
+-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
+ pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
+-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
-finalIfaceInfo iface_cache imps_reqd imp_mods
- = return ([], [])
+ return (emptyFM, emptyFM, [])
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index b3a142b02037..27dd750a394d 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -508,16 +508,16 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
(vals, tcs, ies_left) = do_builtin ies
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
+getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
= (map mkAllIE (eltsFM exps), [], emptyBag)
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
+getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
= (map mkAllIE (eltsFM exps_left), found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
+getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
= (map fst found_ies, found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
@@ -622,7 +622,7 @@ getFixityDecl iface_cache rn
case maybe_iface of
Failed err ->
return (Nothing, unitBag err)
- Succeeded (ParsedIface _ _ _ _ _ _ fixes _ _ _ _) ->
+ Succeeded (ParsedIface _ _ _ _ _ _ _ fixes _ _ _ _) ->
case lookupFM fixes str of
Nothing -> return (Nothing, emptyBag)
Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index b534011a6337..a49aadb68203 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -14,11 +14,7 @@ then discover that they aren't needed in the chosen branch.
\begin{code}
#include "HsVersions.h"
-module FloatIn (
- floatInwards
-
- -- and to make the interface self-sufficient...
- ) where
+module FloatIn ( floatInwards ) where
import Ubiq{-uitous-}
@@ -391,9 +387,9 @@ sepBindsByDropPoint drop_pts floaters
-------------------------
fvsOfBind (_,fvs) = fvs
---floatedBindsFVs ::
+floatedBindsFVs :: FloatingBinds -> FreeVarsSet
floatedBindsFVs binds = unionManyIdSets (map snd binds)
---mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
+mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
\end{code}
diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index c1de41735066..401300459f42 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -22,7 +22,7 @@ import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv(..),
import Outputable ( Outputable(..){-instance (,)-} )
import PprCore ( GenCoreBinding{-instance-} )
import PprStyle ( PprStyle(..) )
-import PprType -- too lazy to type in all the instances
+import PprType ( GenTyVar )
import Pretty ( ppInt, ppStr, ppBesides, ppAboves )
import SetLevels -- all of it
import TyVar ( GenTyVar{-instance Eq-} )
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index eea04438f372..dffde6b86d62 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -89,7 +89,7 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do
SpecialiseData) -- specialisation data
core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
- = BSCC("Core2Core")
+ = _scc_ "Core2Core"
if null core_todos then -- very rare, I suspect...
-- well, we still must do some renumbering
return (
@@ -118,7 +118,6 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
) >>
return (processed_binds, inline_env, spec_data)
- ESCC
where
init_specdata = initSpecData local_tycons tycon_specs
@@ -142,7 +141,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
in
case to_do of
CoreDoSimplify simpl_sw_chkr
- -> BSCC("CoreSimplify")
+ -> _scc_ "CoreSimplify"
begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
then " (foldr/build)" else "") >>
case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
@@ -151,76 +150,66 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
("Simplify (" ++ show it_cnt ++ ")"
++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
then " foldr/build" else "")
- ESCC
CoreDoFoldrBuildWorkerWrapper
- -> BSCC("CoreDoFoldrBuildWorkerWrapper")
+ -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
begin_pass "FBWW" >>
case (mkFoldrBuildWW us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
- } ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
CoreDoFoldrBuildWWAnal
- -> BSCC("CoreDoFoldrBuildWWAnal")
+ -> _scc_ "CoreDoFoldrBuildWWAnal"
begin_pass "AnalFBWW" >>
case (analFBWW binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
- } ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
CoreLiberateCase
- -> BSCC("LiberateCase")
+ -> _scc_ "LiberateCase"
begin_pass "LiberateCase" >>
case (liberateCase lib_case_threshold binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
- } ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
- -> BSCC("CoreInlinings1")
+ -> _scc_ "CoreInlinings1"
begin_pass "CalcInlinings" >>
case (calcInlinings False inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
- } ESCC
+ end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
- -> BSCC("CoreInlinings2")
+ -> _scc_ "CoreInlinings2"
begin_pass "CalcInlinings" >>
case (calcInlinings True inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
- } ESCC
+ end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
CoreDoFloatInwards
- -> BSCC("FloatInwards")
+ -> _scc_ "FloatInwards"
begin_pass "FloatIn" >>
case (floatInwards binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
- } ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
CoreDoFullLaziness
- -> BSCC("CoreFloating")
+ -> _scc_ "CoreFloating"
begin_pass "FloatOut" >>
case (floatOutwards us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
- } ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
CoreDoStaticArgs
- -> BSCC("CoreStaticArgs")
+ -> _scc_ "CoreStaticArgs"
begin_pass "StaticArgs" >>
case (doStaticArgs binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs"
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
-- Binds really should be dependency-analysed for static-
-- arg transformation... Not to worry, they probably are.
-- (I don't think it *dies* if they aren't [WDP 94/04/15])
- } ESCC
CoreDoStrictness
- -> BSCC("CoreStranal")
+ -> _scc_ "CoreStranal"
begin_pass "StrAnal" >>
case (saWwTopBinds us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
- } ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
CoreDoSpecialising
- -> BSCC("Specialise")
+ -> _scc_ "Specialise"
begin_pass "Specialise" >>
case (specProgram us1 binds spec_data) of {
(p, spec_data2@(SpecData _ spec_noerrs _ _ _
@@ -242,27 +231,22 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
}
- ESCC
CoreDoDeforest
#if OMIT_DEFORESTER
-> error "ERROR: CoreDoDeforest: not built into compiler\n"
#else
- -> BSCC("Deforestation")
+ -> _scc_ "Deforestation"
begin_pass "Deforestation" >>
case (deforestProgram binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
- }
- ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
#endif
CoreDoAutoCostCentres
- -> BSCC("AutoSCCs")
+ -> _scc_ "AutoSCCs"
begin_pass "AutoSCCs" >>
case (addAutoCostCentres module_name binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
- }
- ESCC
+ end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" }
CoreDoPrintCore -- print result of last pass
-> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi
index 3a9e3493e87e..ddffa3bbbd58 100644
--- a/ghc/compiler/simplCore/SmplLoop.lhi
+++ b/ghc/compiler/simplCore/SmplLoop.lhi
@@ -13,14 +13,20 @@ import SimplEnv ( SimplEnv, InBinding(..), InExpr(..),
OutArg(..), OutExpr(..), OutType(..)
)
import Simplify ( simplExpr, simplBind )
-import SimplMonad ( SmplM(..) )
+
+import BinderInfo(BinderInfo)
+import CoreSyn(GenCoreArg, GenCoreBinding, GenCoreExpr)
+import Id(GenId)
+import SimplMonad(SimplCount)
+import TyVar(GenTyVar)
+import Type(GenType)
+import UniqSupply(UniqSupply)
+import Unique(Unique)
+import Usage(GenUsage)
data MagicUnfoldingFun
+data SimplCount
-simplExpr :: SimplEnv -> InExpr -> [OutArg] -> SmplM OutExpr
-simplBind :: SimplEnv
- -> InBinding
- -> (SimplEnv -> SmplM OutExpr)
- -> OutType
- -> SmplM OutExpr
+simplBind :: SimplEnv -> GenCoreBinding (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> (SimplEnv -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)) -> GenType (GenTyVar (GenUsage Unique)) Unique -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)
+simplExpr :: SimplEnv -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique] -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)
\end{code}
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 437f8888195a..4335884ad201 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -53,7 +53,7 @@ stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
[CostCentre])) -- "extern" cost-centres
stg2stg stg_todos module_name ppr_style us binds
- = BSCC("Stg2Stg")
+ = _scc_ "Stg2Stg"
case (splitUniqSupply us) of { (us4now, us4later) ->
(if do_verbose_stg2stg then
@@ -103,7 +103,6 @@ stg2stg stg_todos module_name ppr_style us binds
in
return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
}}
- ESCC
where
do_let_no_escapes = opt_StgDoLetNoEscapes
do_verbose_stg2stg = opt_D_verbose_stg2stg
@@ -130,43 +129,39 @@ stg2stg stg_todos module_name ppr_style us binds
case to_do of
StgDoStaticArgs ->
ASSERT(null (fst ccs) && null (snd ccs))
- BSCC("StgStaticArgs")
+ _scc_ "StgStaticArgs"
let
binds3 = doStaticArgs binds us1
in
end_pass us2 "StgStaticArgs" ccs binds3
- ESCC
StgDoUpdateAnalysis ->
ASSERT(null (fst ccs) && null (snd ccs))
- BSCC("StgUpdAnal")
+ _scc_ "StgUpdAnal"
-- NB We have to do setStgVarInfo first! (There's one
-- place free-var info is used) But no let-no-escapes,
-- because update analysis doesn't care.
end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
- ESCC
D_stg_stats ->
trace (showStgStats binds)
end_pass us2 "StgStats" ccs binds
StgDoLambdaLift ->
- BSCC("StgLambdaLift")
+ _scc_ "StgLambdaLift"
-- NB We have to do setStgVarInfo first!
let
binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
in
end_pass us2 "LambdaLift" ccs binds3
- ESCC
StgDoMassageForProfiling ->
- BSCC("ProfMassage")
+ _scc_ "ProfMassage"
let
(collected_CCs, binds3)
= stgMassageForProfiling module_name grp_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
- ESCC
end_pass us2 what ccs binds2
= -- report verbosely, if required
@@ -225,10 +220,9 @@ unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv,
unlocaliseStgBinds mod uenv [] = (uenv, [])
unlocaliseStgBinds mod uenv (b : bs)
- = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) ->
- BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
- (uenv3, new_b : new_bs)
- BEND BEND
+ = case (unlocal_top_bind mod uenv b) of { (new_uenv, new_b) ->
+ case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
+ (uenv3, new_b : new_bs) }}
------------------
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 9f3c14b22407..8c7c7dbe7c93 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -54,7 +54,7 @@ Checks for
lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
lintStgBindings sty whodunnit binds
- = BSCC("StgLint")
+ = _scc_ "StgLint"
case (initL (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (ppAboves [
@@ -63,7 +63,6 @@ lintStgBindings sty whodunnit binds
ppStr "*** Offending Program ***",
ppAboves (map (pprPlainStgBinding sty) binds),
ppStr "*** End of Offense ***"])
- ESCC
where
lint_binds :: [StgBinding] -> LintM ()
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 35554f358a8f..7a0fbb10e434 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -14,7 +14,7 @@ module GenSpecEtc (
import Ubiq
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
newDicts, tyVarsOfInst, instToId )
import TcEnv ( tcGetGlobalTyVars )
@@ -36,6 +36,7 @@ import Id ( GenId, Id(..), mkUserId, idType )
import Kind ( isUnboxedKind, isTypeKind, mkBoxedTypeKind )
import ListSetOps ( minusList, unionLists, intersectLists )
import Maybes ( Maybe(..), allMaybes )
+import Name ( Name{--O only-} )
import Outputable ( interppSP, interpp'SP )
import Pretty
import PprType ( GenClass, GenType, GenTyVar )
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index be598f202cb1..a24e7acd1a9b 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -36,7 +36,7 @@ import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
mkHsTyApp, mkHsDictApp )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupGlobalValueByKey )
import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
tcInstType, tcInstTcType, zonkTcType )
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 4d4a1ad24893..21be1952404f 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -20,7 +20,7 @@ import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
TcIdOcc(..), TcIdBndr(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index df5924d5fee7..a4c43af3dff5 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -25,7 +25,7 @@ import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
import TcInstDcls ( processInstBinds )
diff --git a/ghc/compiler/typecheck/TcClassSig.lhs b/ghc/compiler/typecheck/TcClassSig.lhs
index 048b9e24b8dc..08e2fe10bb1a 100644
--- a/ghc/compiler/typecheck/TcClassSig.lhs
+++ b/ghc/compiler/typecheck/TcClassSig.lhs
@@ -8,7 +8,7 @@
module TcClassSig ( tcClassSigs ) where
-import TcMonad -- typechecking monadic machinery
+import TcMonad hiding ( rnMtoTcM )
import HsSyn -- the stuff being typechecked
import Type
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 5ea9905e609e..0296080e8aa8 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -15,7 +15,7 @@ import HsSyn ( DefaultDecl(..), MonoType,
import RnHsSyn ( RenamedDefaultDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstOrigin(..) )
import TcEnv ( tcLookupClassByKey )
import TcMonoType ( tcMonoType )
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index b0791642cb75..778a28a6a079 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -8,9 +8,7 @@ Handles @deriving@ clauses on @data@ declarations.
\begin{code}
#include "HsVersions.h"
-module TcDeriv (
- tcDeriving
- ) where
+module TcDeriv ( tcDeriving ) where
import Ubiq
@@ -21,7 +19,7 @@ import HsPragmas ( InstancePragmas(..) )
import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstOrigin(..), InstanceMapper(..) )
import TcEnv ( getEnv_TyCons )
import TcKind ( TcKind )
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index a30ed69da21a..ba1bcbf3a3da 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -34,7 +34,7 @@ import Type ( tyVarsOfTypes )
import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity )
import Class ( Class(..), GenClass, classSig )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
import PprStyle
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 6454e1a53047..c5d9e36c2401 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -24,7 +24,7 @@ import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
mkHsTyApp
)
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index a5d1fc06d703..44bdfce15c2e 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -14,7 +14,7 @@ import HsSyn ( GRHSsAndBinds(..), GRHS(..),
import RnHsSyn ( RenamedGRHSsAndBinds(..), RenamedGRHS(..) )
import TcHsSyn ( TcGRHSsAndBinds(..), TcGRHS(..), TcIdOcc(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, LIE(..), plusLIE )
import TcBinds ( tcBindsAndThen )
import TcExpr ( tcExpr )
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index d70b25c95d36..3c86baf7eb4d 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -42,7 +42,7 @@ import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
)
-- others:
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcType ( TcType(..), TcMaybe, TcTyVar(..),
zonkTcTypeToType, zonkTcTyVarToTyVar,
tcInstType
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 65e295098f13..9e60168493c4 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -10,7 +10,7 @@ module TcIfaceSig ( tcInterfaceSigs ) where
import Ubiq
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcMonoType ( tcPolyType )
import HsSyn ( Sig(..), PolyType )
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 3ea432f2a073..238e3fd58a17 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -32,7 +32,7 @@ import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
mkHsDictLam, mkHsDictApp )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars )
import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
@@ -64,7 +64,7 @@ import Class ( GenClass, GenClassOp,
import Id ( GenId, idType, isDefaultMethodId_maybe )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust )
-import Name ( getLocalName, origName, nameOf )
+import Name ( getLocalName, origName, nameOf, Name{--O only-} )
import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID )
import PrelMods ( pRELUDE )
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 599d53f2affd..c8180abecaa6 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -20,7 +20,7 @@ import HsSyn ( MonoBinds, Fake, InPat, Sig )
import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstanceMapper(..) )
import Bag ( bagToList )
@@ -30,7 +30,7 @@ import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
-import Name ( getSrcLoc )
+import Name ( getSrcLoc, Name{--O only-} )
import PprType ( GenClass, GenType, GenTyVar )
import Pretty
import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
index 71cba23e9fba..3026867af98f 100644
--- a/ghc/compiler/typecheck/TcKind.lhs
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -15,7 +15,7 @@ module TcKind (
) where
import Kind
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Ubiq
import Unique ( Unique, pprUnique10 )
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 47968f2cb176..87628cf432dd 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -16,7 +16,7 @@ import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
import RnHsSyn ( RenamedMatch(..) )
import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, LIE(..), plusLIE )
import TcEnv ( newMonoIds )
import TcLoop ( tcGRHSsAndBinds )
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index dccaab2a2e69..f279531d5cf2 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -27,7 +27,7 @@ import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
TcIdOcc(..), zonkBinds, zonkInst, zonkId )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, plusLIE )
import TcBinds ( tcBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 50f80cf7e309..34b628dede6a 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -16,7 +16,7 @@ import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
)
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
tcTyVarScope, tcTyVarScopeGivenKinds
)
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 3daadf63c8d6..bb9f71e23f58 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -16,7 +16,7 @@ import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
import RnHsSyn ( RenamedPat(..) )
import TcHsSyn ( TcPat(..), TcIdOcc(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
emptyLIE, plusLIE, plusLIEs, LIE(..),
newMethod, newOverloadedLit
diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs
index cebb20dbbb56..40df4a814aaf 100644
--- a/ghc/compiler/typecheck/TcPragmas.lhs
+++ b/ghc/compiler/typecheck/TcPragmas.lhs
@@ -13,12 +13,10 @@ module TcPragmas (
tcGenPragmas
) where
-import TcMonad -- typechecking monadic machinery
+import TcMonad hiding ( rnMtoTcM )
import HsSyn -- the stuff being typechecked
import PrelInfo ( PrimOp(..) -- to see CCallOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import Type
import CmdLineOpts
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 044ddab73cf5..bcb90dd97cf1 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -19,7 +19,7 @@ import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
GRHSsAndBinds, Stmt, Fake )
import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst,
instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 78d56f485f48..fce676f44940 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -20,7 +20,7 @@ import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
)
import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstanceMapper(..) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index cd62d7cb3bf6..b117f2fa94c6 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -32,7 +32,7 @@ import TcType ( tcInstTyVars, tcInstType, tcInstId )
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
newLocalId, newLocalIds
)
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
import Class ( GenClass{-instance Eq-} )
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 8426310f011a..44fc091184d8 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -45,7 +45,7 @@ import Class ( GenClass )
import Id ( idType )
import Kind ( Kind )
import TcKind ( TcKind )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import Ubiq
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index ad979b77349c..11d0545e669f 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -14,7 +14,7 @@ module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
import Ubiq
-- friends:
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
import TyCon ( TyCon, mkFunTyCon )
import TyVar ( GenTyVar(..), TyVar(..), tyVarKind )
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 6710032aa6ef..0b1e3d9f8bbf 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -47,7 +47,7 @@ module FiniteMap (
plusFM,
plusFM_C,
- minusFM, -- exported for GHCI only
+ minusFM,
IF_NOT_GHC(intersectFM COMMA)
IF_NOT_GHC(intersectFM_C COMMA)
@@ -60,7 +60,7 @@ module FiniteMap (
#ifdef COMPILING_GHC
, bagToFM
, FiniteSet(..), emptySet, mkSet, isEmptySet
- , elementOf, setToList, union, minusSet{-exported for GHCI-}
+ , elementOf, setToList, union, minusSet
#endif
-- To make it self-sufficient
diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs
index fe9dcca7fe6b..3be4d8932564 100644
--- a/ghc/compiler/utils/ListSetOps.lhs
+++ b/ghc/compiler/utils/ListSetOps.lhs
@@ -14,11 +14,9 @@ module ListSetOps (
) where
#if defined(COMPILING_GHC)
-import Util
-# ifdef USE_ATTACK_PRAGMAS
-import Type
-import Id ( Id )
-# endif
+import Ubiq{-uitous-}
+
+import Util ( isIn, isn'tIn )
#endif
\end{code}
@@ -77,19 +75,3 @@ disjointLists (a:as) bs
intersectingLists xs ys = not (disjointLists xs ys)
#endif
\end{code}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-
-{-# SPECIALIZE unionLists :: [TyVar] -> [TyVar] -> [TyVar] #-}
-{-# SPECIALIZE intersectLists :: [TyVar] -> [TyVar] -> [TyVar] #-}
-
-{-# SPECIALIZE minusList :: [TyVar] -> [TyVar] -> [TyVar],
- [Id] -> [Id] -> [Id],
- [Int] -> [Int] -> [Int]
- #-}
-
-# endif
-#endif
-\end{code}
diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs
index 146553409f6a..3a29c7f017bb 100644
--- a/ghc/compiler/utils/Maybes.lhs
+++ b/ghc/compiler/utils/Maybes.lhs
@@ -12,7 +12,7 @@ module Maybes (
-- Maybe(..), -- no, it's in 1.3
MaybeErr(..),
- allMaybes, -- GHCI only
+ allMaybes,
catMaybes,
firstJust,
expectJust,
@@ -24,11 +24,11 @@ module Maybes (
failMaB,
failMaybe,
seqMaybe,
- mapMaybe, -- GHCI only
+ mapMaybe,
returnMaB,
- returnMaybe, -- GHCI only
+ returnMaybe,
thenMaB,
- thenMaybe -- GHCI only
+ thenMaybe
#if ! defined(COMPILING_GHC)
, findJust
@@ -41,9 +41,6 @@ module Maybes (
CHK_Ubiq() -- debugging consistency check
-#if USE_ATTACK_PRAGMAS
-import Util
-#endif
#endif
\end{code}
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 09fcdc78fc62..455cea2f2713 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -49,17 +49,6 @@ interpp'SP sty xs
= ppIntersperse sep (map (ppr sty) xs)
where
sep = ppBeside ppComma ppSP
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
-{-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
-
-{-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-}
-#endif
\end{code}
\begin{code}
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 0ce1f4992188..c6e92c0740d9 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -80,9 +80,7 @@ module Util (
-- error handling
#if defined(COMPILING_GHC)
, panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
-# ifdef DEBUG
, assertPanic
-# endif
#endif {- COMPILING_GHC -}
-- and to make the interface self-sufficient...
@@ -258,27 +256,6 @@ isn'tIn msg x ys
# endif {- DEBUG -}
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isIn :: String -> Literal -> [Literal] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
-# endif
-
#endif {- COMPILING_GHC -}
\end{code}
@@ -298,21 +275,6 @@ assoc crash_msg lst key
then panic ("Failed in assoc: " ++ crash_msg)
else head res
where res = [ val | (key', val) <- lst, key == key']
-
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE assoc :: String -> [(Id, a)] -> Id -> a #-}
-{-# SPECIALIZE assoc :: String -> [(Class, a)] -> Class -> a #-}
-{-# SPECIALIZE assoc :: String -> [(Name, a)] -> Name -> a #-}
-{-# SPECIALIZE assoc :: String -> [(PrimRep, a)] -> PrimRep -> a #-}
-{-# SPECIALIZE assoc :: String -> [(String, a)] -> String -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyCon, a)] -> TyCon -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyVar, a)] -> TyVar -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-}
-{-# SPECIALIZE assoc :: String -> [(Type, a)] -> Type -> a #-}
-{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
-# endif
-#endif
\end{code}
%************************************************************************
@@ -337,11 +299,6 @@ hasNoDups xs = f [] xs
#else
is_elem = elem
#endif
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-}
-# endif
-#endif
\end{code}
\begin{code}
@@ -844,9 +801,8 @@ panic# s = case (panic s) of () -> EQ_
pprPanic# heading pretty_msg = panic# (heading++(ppShow 80 pretty_msg))
-# ifdef DEBUG
assertPanic :: String -> Int -> a
assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-# endif
+
#endif {- COMPILING_GHC -}
\end{code}
--
GitLab