#endif
-#define MkInt I#
-#define MkChar C#
-#define MkArray _Array
-
#ifdef __GLASGOW_HASKELL__
#define TAG_ Int#
#define LT_ -1#
#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
#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
#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
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}
_ ->
-- 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) ->
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,
]
else
the_op
- BEND
+ }
where
ppr_op_call results args
= uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
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
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(",
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
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
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:
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
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)
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}
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
= 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}
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}
import PragmaInfo ( PragmaInfo(..) )
import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
- nmbrType, addTyVar,
+ nmbrType, nmbrTyVar,
GenType, GenTyVar
)
import PprStyle
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}
%************************************************************************
(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
-- 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.
(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)
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}
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 ->
\begin{code}
mkUnfolding guide expr
= GenForm False (mkFormSummary NoStrictnessInfo expr)
- (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
+ (occurAnalyseGlobalExpr expr)
guide
\end{code}
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}
%************************************************************************
\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
= 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}
\end{code}
\begin{code}
-mkSplitUniqSupply (MkChar c#)
+mkSplitUniqSupply (C# c#)
= let
mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
(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
\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}
%************************************************************************
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
layOutDynClosure, layOutDynCon, layOutStaticClosure,
layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
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
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
\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 ->
> import Type ( applyTypeEnvToTy, isPrimType,
> SigmaType(..), Type
-> IF_ATTACK_PRAGMAS(COMMA cmpUniType)
> )
> import CmdLineOpts ( SwitchResult, switchIsOn )
> import CoreUnfold ( UnfoldingDetails(..) )
> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
> tyVarsOfType, TyVar, SigmaType(..)
-> IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
> )
> import Literal ( Literal ) -- for Eq Literal
> import CoreSyn
import HsLoop ( HsExpr, nullBinds, HsBinds )
import Outputable ( ifPprShowAll )
-import PprType
+import PprType ( GenType{-instance Outputable-} )
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
import Util ( panic )
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"
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 }
import CmdLineOpts
import ErrUtils ( pprBagOfErrors, ghcExit )
import Maybes ( maybeToBool, MaybeErr(..) )
-import PrelInfo ( builtinNameInfo )
import RdrHsSyn ( getRawExportees )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
-- ******* READER
show_pass "Reader" >>
+ _scc_ "Reader"
rdModule >>= \ (mod_name, rdr_module) ->
doDump opt_D_dump_rdr "Reader:"
(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
-- (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 >>
-- ******* TYPECHECKER
show_pass "TypeCheck" >>
+ _scc_ "TypeCheck"
case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
-- ******* DESUGARER
show_pass "DeSugar" >>
+ _scc_ "DeSugar"
let
(desugared,ds_warnings)
= deSugar ds_uniqs mod_name typechecked_quint
>>
-- ******* 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
>>=
-- ******* 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
>>=
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
show_pass "CodeGen" >>
+ _scc_ "CodeGen"
let
abstractC = codeGen mod_name -- module name for CC labelling
cost_centre_info
doOutput opt_ProduceC c_output_w >>
ghcExit 0
- } ) } }
+ } ) }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
module MkIface (
startIface, endIface,
+ ifaceUsages,
ifaceVersions,
ifaceExportList,
ifaceFixities,
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(..) )
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
\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}
%token
INTERFACE { ITinterface }
+ USAGES_PART { ITusages }
VERSIONS_PART { ITversions }
EXPORTS_PART { ITexports }
INSTANCE_MODULES_PART { ITinstance_modules }
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)
--------------------------------------------------------------------------
}
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 }
\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
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
-----------------------------------------------------------------
data IfaceToken
= ITinterface -- keywords
+ | ITusages
| ITversions
| ITexports
| ITinstance_modules
keywordsFM = listToFM [
("interface", ITinterface)
+ ,("__usages__", ITusages)
,("__versions__", ITversions)
,("__exports__", ITexports)
,("__instance_modules__",ITinstance_modules)
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 )
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 )
\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)
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))
}) >>= \ (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 ...
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
\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 }],
pprRdrInstDecl (InstSig c t _ decl)
= ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
ppr PprDebug decl]
+-}
\end{code}
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)
-- 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"
cachedDecl,
readIface,
rnIfaces,
- finalIfaceInfo,
- IfaceCache(..),
- VersionInfo(..)
+ IfaceCache(..)
) where
import Ubiq
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-}
= 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))
-> 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
= {-
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))) $
-}
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
src_loc,
if_final_env,
if_implicits,
+ usage_stuff,
if_errs_warns)
where
decls_and_insts todo def_env occ_env to_return us
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 ->
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
\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}
(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
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)
\begin{code}
#include "HsVersions.h"
-module FloatIn (
- floatInwards
-
- -- and to make the interface self-sufficient...
- ) where
+module FloatIn ( floatInwards ) where
import Ubiq{-uitous-}
-------------------------
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}
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-} )
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 (
) >>
return (processed_binds, inline_env, spec_data)
- ESCC
where
init_specdata = initSpecData local_tycons tycon_specs
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
("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 _ _ _
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"
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}
[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
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
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
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) }}
------------------
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 [
ppStr "*** Offending Program ***",
ppAboves (map (pprPlainStgBinding sty) binds),
ppStr "*** End of Offense ***"])
- ESCC
where
lint_binds :: [StgBinding] -> LintM ()
import Ubiq
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
newDicts, tyVarsOfInst, instToId )
import TcEnv ( tcGetGlobalTyVars )
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 )
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 )
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 )
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 )
module TcClassSig ( tcClassSigs ) where
-import TcMonad -- typechecking monadic machinery
+import TcMonad hiding ( rnMtoTcM )
import HsSyn -- the stuff being typechecked
import Type
import RnHsSyn ( RenamedDefaultDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstOrigin(..) )
import TcEnv ( tcLookupClassByKey )
import TcMonoType ( tcMonoType )
\begin{code}
#include "HsVersions.h"
-module TcDeriv (
- tcDeriving
- ) where
+module TcDeriv ( tcDeriving ) where
import Ubiq
import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstOrigin(..), InstanceMapper(..) )
import TcEnv ( getEnv_TyCons )
import TcKind ( TcKind )
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
mkHsTyApp
)
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
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 )
)
-- others:
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcType ( TcType(..), TcMaybe, TcTyVar(..),
zonkTcTypeToType, zonkTcTyVarToTyVar,
tcInstType
import Ubiq
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcMonoType ( tcPolyType )
import HsSyn ( Sig(..), PolyType )
mkHsDictLam, mkHsDictApp )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars )
import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
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,
import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstanceMapper(..) )
import Bag ( bagToList )
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 )
) where
import Kind
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Ubiq
import Unique ( Unique, pprUnique10 )
import RnHsSyn ( RenamedMatch(..) )
import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, LIE(..), plusLIE )
import TcEnv ( newMonoIds )
import TcLoop ( tcGRHSsAndBinds )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
TcIdOcc(..), zonkBinds, zonkInst, zonkId )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, plusLIE )
import TcBinds ( tcBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
)
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
tcTyVarScope, tcTyVarScopeGivenKinds
)
import RnHsSyn ( RenamedPat(..) )
import TcHsSyn ( TcPat(..), TcIdOcc(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
emptyLIE, plusLIE, plusLIEs, LIE(..),
newMethod, newOverloadedLit
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
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,
)
import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstanceMapper(..) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
newLocalId, newLocalIds
)
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
import Class ( GenClass{-instance Eq-} )
import Id ( idType )
import Kind ( Kind )
import TcKind ( TcKind )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import Ubiq
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 )
plusFM,
plusFM_C,
- minusFM, -- exported for GHCI only
+ minusFM,
IF_NOT_GHC(intersectFM COMMA)
IF_NOT_GHC(intersectFM_C COMMA)
#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
) 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}
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}
-- Maybe(..), -- no, it's in 1.3
MaybeErr(..),
- allMaybes, -- GHCI only
+ allMaybes,
catMaybes,
firstJust,
expectJust,
failMaB,
failMaybe,
seqMaybe,
- mapMaybe, -- GHCI only
+ mapMaybe,
returnMaB,
- returnMaybe, -- GHCI only
+ returnMaybe,
thenMaB,
- thenMaybe -- GHCI only
+ thenMaybe
#if ! defined(COMPILING_GHC)
, findJust
CHK_Ubiq() -- debugging consistency check
-#if USE_ATTACK_PRAGMAS
-import Util
-#endif
#endif
\end{code}
= 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}
-- 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...
# 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}
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}
%************************************************************************
#else
is_elem = elem
#endif
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-}
-# endif
-#endif
\end{code}
\begin{code}
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}
projects / ghc-hetmet.git / commitdiff