Commit a77abe6a authored by partain's avatar partain

[project @ 1996-04-25 16:31:20 by partain]

SLPJ 1.3 changes through 960425
parent 4250d641
......@@ -154,7 +154,6 @@ typecheck/TcPat.lhs \
typecheck/TcSimplify.lhs \
typecheck/TcTyClsDecls.lhs \
typecheck/TcTyDecls.lhs \
typecheck/Typecheck.lhs \
typecheck/Unify.lhs
/*
......@@ -319,14 +318,10 @@ utils/Unpretty.lhs \
utils/Util.lhs
#define MAIN_SRCS_LHS \
main/MainMonad.lhs \
main/CmdLineOpts.lhs \
main/ErrUtils.lhs \
main/Main.lhs
/*
main/MkIface.lhs \
*/
main/Main.lhs
#define VBASICSRCS_LHS \
prelude/PrelMods.lhs \
......@@ -587,7 +582,6 @@ compile(deSugar/MatchLit,lhs,)
compile(main/CmdLineOpts,lhs,if_ghc(-fvia-C))
compile(main/ErrUtils,lhs,)
compile(main/Main,lhs,if_ghc(-fvia-C))
compile(main/MainMonad,lhs,)
compile(main/MkIface,lhs,)
#if GhcWithNativeCodeGen == YES
......@@ -718,7 +712,6 @@ compile(typecheck/TcPragmas,lhs,)
compile(typecheck/TcSimplify,lhs,)
compile(typecheck/TcTyClsDecls,lhs,)
compile(typecheck/TcTyDecls,lhs,)
compile(typecheck/Typecheck,lhs,)
compile(typecheck/Unify,lhs,)
compile(types/Class,lhs,)
......
......@@ -97,7 +97,7 @@ import IdLoop -- for paranoia checking
import TyLoop -- for paranoia checking
import Bag
import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
......@@ -1039,7 +1039,7 @@ getIdNamePieces show_uniqs id
MethodSelId clas op ->
case (moduleNamePair clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
case (classOpString op) of { op_name ->
if isPreludeDefined clas
then [op_name]
else [c_mod, c_name, op_name]
......@@ -1047,7 +1047,7 @@ getIdNamePieces show_uniqs id
DefaultMethodId clas op _ ->
case (moduleNamePair clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
case (classOpString op) of { op_name ->
if isPreludeDefined clas
then [SLIT("defm"), op_name]
else [SLIT("defm"), c_mod, c_name, op_name] }}
......@@ -1066,7 +1066,7 @@ getIdNamePieces show_uniqs id
ConstMethodId c ty o _ _ ->
case (moduleNamePair c) of { (c_mod, c_name) ->
case (getTypeString ty) of { ty_bits ->
case (getClassOpString o) of { o_name ->
case (classOpString o) of { o_name ->
case (if isPreludeDefined c
then [c_name]
else [c_mod, c_name]) of { c_bits ->
......@@ -1142,7 +1142,7 @@ getInstIdModule other = panic "Id:getInstIdModule"
\begin{code}
mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
mkDictFunId u c ity full_ty from_here mod info
......@@ -1817,7 +1817,7 @@ instance NamedThing (GenId ty) where
{- LATER:
get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
mod -> (mod, getClassOpString op)
mod -> (mod, classOpString op)
get (SpecId unspec ty_maybes _)
= BIND moduleNamePair unspec _TO_ (mod, unspec_nm) ->
......
......@@ -28,10 +28,12 @@ module Name (
mkTupNameStr,
NamedThing(..), -- class
ExportFlag(..), isExported,
ExportFlag(..),
isExported{-overloaded-}, exportFlagOn{-not-},
nameUnique,
nameOccName,
nameOrigName,
nameExportFlag,
nameSrcLoc,
nameImportFlag,
......@@ -340,10 +342,10 @@ data ExportFlag
| ExportAbs -- export abstractly (tycons/classes only)
| NotExported
isExported a
= case (getExportFlag a) of
NotExported -> False
_ -> True
exportFlagOn NotExported = False
exportFlagOn _ = True
isExported a = exportFlagOn (getExportFlag a)
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isExported :: Class -> Bool #-}
......@@ -400,17 +402,7 @@ as to canonicalize interfaces. [Regular @(<)@ should be used for fast
comparison.]
\begin{code}
a `ltLexical` b
= case (moduleNamePair a) of { (a_mod, a_name) ->
case (moduleNamePair b) of { (b_mod, b_name) ->
if isLocallyDefined a || isLocallyDefined b then
a_name < b_name -- can't compare module names
else
case _CMP_STRING_ a_mod b_mod of
LT_ -> True
EQ_ -> a_name < b_name
GT__ -> False
}}
a `ltLexical` b = origName a < origName b
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
......
......@@ -63,7 +63,7 @@ data UniqSupply
\end{code}
\begin{code}
mkSplitUniqSupply :: Char -> PrimIO UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
getUnique :: UniqSupply -> Unique
......@@ -97,7 +97,8 @@ mkSplitUniqSupply (MkChar c#)
mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
returnPrimIO (MkInt (w2i (mask# `or#` u#)))
in
mk_supply#
mk_supply# `thenPrimIO` \ s ->
return s
splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
\end{code}
......
......@@ -120,6 +120,8 @@ module Unique (
recUpdErrorIdKey,
irrefutPatErrorIdKey,
nonExhaustiveGuardsErrorIdKey,
noDefaultMethodErrorIdKey,
nonExplicitMethodErrorIdKey,
primIoTyConKey,
ratioDataConKey,
ratioTyConKey,
......@@ -568,12 +570,14 @@ recConErrorIdKey = mkPreludeMiscIdUnique 29
recUpdErrorIdKey = mkPreludeMiscIdUnique 30
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33
nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34
#ifdef GRAN
parLocalIdKey = mkPreludeMiscIdUnique 33
parGlobalIdKey = mkPreludeMiscIdUnique 34
noFollowIdKey = mkPreludeMiscIdUnique 35
copyableIdKey = mkPreludeMiscIdUnique 36
parLocalIdKey = mkPreludeMiscIdUnique 35
parGlobalIdKey = mkPreludeMiscIdUnique 36
noFollowIdKey = mkPreludeMiscIdUnique 37
copyableIdKey = mkPreludeMiscIdUnique 38
#endif
\end{code}
......
......@@ -277,10 +277,15 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
Just (tyvar,body) ->
if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then
let
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
if (tyvar_kind `isSubKindOf` argty_kind
|| argty_kind `isSubKindOf` tyvar_kind) then
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
else
pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $
pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
lintCoreArg _ e ty (UsageArg u)
......
......@@ -340,7 +340,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
(tycon, _, _) = getAppDataTyCon scrut_ty
(tycon, _, _) = _trace "getAppDataTyCon.CoreUnfold" $ getAppDataTyCon scrut_ty
size_up_alts _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
......
......@@ -12,7 +12,6 @@ module CoreUtils (
substCoreExpr, substCoreBindings
, mkCoreIfThenElse
, escErrorMsg -- ToDo: kill
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
......@@ -130,7 +129,8 @@ default_ty (BindDefault _ rhs) = coreExprType rhs
\end{code}
\begin{code}
applyTypeToArgs = panic "applyTypeToArgs"
applyTypeToArgs op_ty args
= foldl applyTy op_ty [ ty | TyArg ty <- args ]
\end{code}
%************************************************************************
......@@ -151,23 +151,6 @@ mkCoreIfThenElse guard then_expr else_expr
NoDefault )
\end{code}
\begin{code}
{- OLD:
mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr
mkErrorApp err_fun ty str_var error_msg
= Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
mkApp (Var err_fun) [] [ty] [VarArg str_var])
-}
escErrorMsg = panic "CoreUtils.escErrorMsg: To Die"
{- OLD:
escErrorMsg [] = []
escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
escErrorMsg (x:xs) = x : escErrorMsg xs
-}
\end{code}
For making @Apps@ and @Lets@, we must take appropriate evasive
action if the thing being bound has unboxed type. @mkCoApp@ requires
a name supply to do its work.
......
......@@ -27,7 +27,7 @@ import Ubiq{-uitous-}
import CoreSyn
import CostCentre ( showCostCentre )
import Id ( idType, getIdInfo, getIdStrictness,
import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
nullIdEnv, DataCon(..), GenId{-instances-}
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
......@@ -303,9 +303,14 @@ ppr_alts pe (AlgAlts alts deflt)
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (con, params, expr)
= ppHang (ppCat [ppr_con con (pCon pe con),
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"])
= ppHang (if isTupleCon con then
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]
else
ppCat [ppr_con con (pCon pe con),
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
4 (ppr_expr pe expr)
where
ppr_con con pp_con
......
......@@ -37,7 +37,11 @@ import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
tyVarsOfType, tyVarsOfTypes
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
import PprCore--ToDo:rm
import PprType--ToDo:rm
import Usage--ToDo:rm
import Unique--ToDo:rm
isDictTy = panic "DsBinds.isDictTy"
\end{code}
......@@ -540,6 +544,8 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
-- we can just use the rhs directly
else
-}
pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
mkSelectorBinds tyvars pat
[(binder, binder_subst binder) | binder <- pat_binders]
body_expr
......
......@@ -413,7 +413,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds)
let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in
let
record_ty = coreExprType record_expr'
(tycon, inst_tys, cons) = getAppDataTyCon record_ty
(tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty
cons_to_upd = filter has_all_fields cons
-- initial_args are passed to every constructor
......
......@@ -40,10 +40,10 @@ import DsMonad
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
import PprType ( pprType{-ToDo:rm-} )
import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
pprId{-ToDo:rm-},
DataCon(..), DictVar(..), Id(..), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon )
......@@ -52,6 +52,12 @@ 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 Pretty--ToDo:rm
import TyVar--ToDo:rm
import Unique--ToDo:rm
import Usage--ToDo:rm
splitDictType = panic "DsUtils.splitDictType"
\end{code}
......@@ -397,7 +403,9 @@ The general case:
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
= newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
= 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 ->
zipWithDs (mk_selector (Var tuple_var))
local_global_prs
......
......@@ -334,7 +334,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
(_, inst_tys, _) = getAppDataTyCon pat_ty
(_, inst_tys, _) = _trace "getAppDataTyCon.Match" $ getAppDataTyCon pat_ty
con_arg_tys' = dataConArgTys con_id inst_tys
tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
......
......@@ -16,7 +16,8 @@ import Ubiq
-- friends:
import HsLoop ( nullMonoBinds, MonoBinds, Sig )
import HsPragmas ( DataPragmas, ClassPragmas,
InstancePragmas, ClassOpPragmas )
InstancePragmas, ClassOpPragmas
)
import HsTypes
-- others:
......@@ -167,8 +168,8 @@ data ConDecl name
SrcLoc
data BangType name
= Banged (MonoType name)
| Unbanged (MonoType name)
= Banged (PolyType name) -- PolyType: to allow Haskell extensions
| Unbanged (PolyType name) -- (MonoType only needed for straight Haskell)
\end{code}
\begin{code}
......@@ -186,8 +187,8 @@ instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
where
pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty)
ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty
ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
\end{code}
%************************************************************************
......
......@@ -15,6 +15,7 @@ module HsTypes (
Context(..), ClassAssertion(..)
#ifdef COMPILING_GHC
, pprParendPolyType
, pprParendMonoType, pprContext
, extractMonoTyNames, extractCtxtTyNames
, cmpPolyType, cmpMonoType, cmpContext
......@@ -102,6 +103,8 @@ pprContext sty context
instance (Outputable name) => Outputable (PolyType name) where
ppr sty (HsPreForAllTy ctxt ty)
= print_it sty ppNil ctxt ty
ppr sty (HsForAllTy [] ctxt ty)
= print_it sty ppNil ctxt ty
ppr sty (HsForAllTy tvs ctxt ty)
= print_it sty
(ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
......@@ -111,6 +114,9 @@ print_it sty pp_forall ctxt ty
= ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
pprContext sty ctxt, ppr sty ty]
pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty
pprParendPolyType sty ty = ppr sty ty -- ToDo: more later
instance (Outputable name) => Outputable (MonoType name) where
ppr = pprMonoType
......
......@@ -223,6 +223,8 @@ 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_EnsureSplittableC = lookup_str "-fglobalise-toplev-names="
opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold"
......@@ -232,6 +234,7 @@ 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 }
......
......@@ -11,7 +11,8 @@ module ErrUtils (
addErrLoc,
addShortErrLocLine,
dontAddErrLoc,
pprBagOfErrors
pprBagOfErrors,
ghcExit
) where
import Ubiq{-uitous-}
......@@ -49,3 +50,12 @@ pprBagOfErrors sty bag_of_errors
= let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in
ppAboves (map (\ p -> ppAbove ppSP p) pretties)
\end{code}
\begin{code}
ghcExit :: Int -> IO ()
ghcExit val
= if val /= 0
then error "Compilation had errors\n"
else return ()
\end{code}
......@@ -10,14 +10,14 @@ module Main ( main ) where
import Ubiq{-uitous-}
import PreludeGlaST ( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this...
import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} )
import MainMonad
import HsSyn
import ReadPrefix ( rdModule )
import Rename ( renameModule )
import Typecheck ( typecheckModule, InstInfo )
import MkIface -- several functions
import TcModule ( typecheckModule )
import Desugar ( deSugar, DsMatchContext, pprDsWarnings )
import SimplCore ( core2core )
import CoreToStg ( topCoreBindsToStg )
......@@ -31,12 +31,14 @@ import AbsCSyn ( absCNop, AbstractC )
import AbsCUtils ( flattenAbsC )
import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
import ErrUtils ( pprBagOfErrors )
import ErrUtils ( pprBagOfErrors, ghcExit )
import Maybes ( maybeToBool, MaybeErr(..) )
import PrelInfo ( builtinNameInfo )
import RdrHsSyn ( getRawExportees )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
import TcInstUtil ( InstInfo )
import UniqSupply ( mkSplitUniqSupply )
import PprAbsC ( dumpRealC, writeRealC )
import PprCore ( pprCoreBinding )
......@@ -49,16 +51,11 @@ import PprType ( GenType, GenTyVar ) -- instances
import RnHsSyn ( RnName ) -- instances
import TyVar ( GenTyVar ) -- instances
import Unique ( Unique ) -- instances
{-
--import MkIface ( mkInterface )
-}
\end{code}
\begin{code}
main
= readMn stdin `thenMn` \ input_pgm ->
= hGetContents stdin >>= \ input_pgm ->
let
cmd_line_info = classifyOpts
in
......@@ -66,77 +63,73 @@ main
\end{code}
\begin{code}
doIt :: ([CoreToDo], [StgToDo]) -> String -> MainIO ()
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
= doDump opt_Verbose "Glasgow Haskell Compiler, version 1.3-xx" ""
`thenMn_`
= doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >>
-- ******* READER
show_pass "Reader" `thenMn_`
rdModule `thenMn`
\ (mod_name, rdr_module) ->
show_pass "Reader" >>
rdModule >>= \ (mod_name, rdr_module) ->
let
-- reader things used much later
ds_mod_name = mod_name
if_mod_name = mod_name
co_mod_name = mod_name
st_mod_name = mod_name
cc_mod_name = mod_name
in
doDump opt_D_dump_rdr "Reader:"
(pp_show (ppr pprStyle rdr_module)) `thenMn_`
(pp_show (ppr pprStyle rdr_module)) >>
doDump opt_D_source_stats "\nSource Statistics:"
(pp_show (ppSourceStats rdr_module)) `thenMn_`
(pp_show (ppSourceStats rdr_module)) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker
getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer
getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier
getSplitUniqSupplyMn 'c' `thenMn` \ c2s_uniqs -> -- core-to-stg
getSplitUniqSupplyMn 'g' `thenMn` \ st_uniqs -> -- stg-to-stg passes
getSplitUniqSupplyMn 'f' `thenMn` \ fl_uniqs -> -- absC flattener
getSplitUniqSupplyMn 'n' `thenMn` \ ncg_uniqs -> -- native-code generator
mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
mkSplitUniqSupply 't' >>= \ 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" `thenMn_`
show_pass "Renamer" >>
case builtinNameInfo
of { (wiredin_fm, key_fm, idinfo_fm) ->
renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn`
renameModule wiredin_fm key_fm rn_uniqs rdr_module >>=
\ (rn_mod, rn_env, import_names,
version_info, instance_modules,
rn_errs_bag, rn_warns_bag) ->
if (not (isEmptyBag rn_errs_bag)) then
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
`thenMn_` writeMn stderr "\n" `thenMn_`
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
`thenMn_` writeMn stderr "\n" `thenMn_`
exitMn 1
hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
>> hPutStr stderr "\n" >>
hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
>> hPutStr stderr "\n" >>
ghcExit 1
else -- No renaming errors ...
(if (isEmptyBag rn_warns_bag) then
returnMn ()
return ()
else
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
`thenMn_` writeMn stderr "\n"
) `thenMn_`
hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
>> hPutStr stderr "\n"
) >>
doDump opt_D_dump_rn "Renamer:"
(pp_show (ppr pprStyle rn_mod)) `thenMn_`
-- exitMn 0
{- LATER ... -}
(pp_show (ppr pprStyle rn_mod)) >>
-- Safely past renaming: we can start the interface file:
-- (the iface file is produced incrementally, as we have
-- the information that we need...; we use "iface<blah>")
-- "endIface" finishes the job.
startIface mod_name >>= \ if_handle ->
ifaceVersions if_handle version_info >>
ifaceExportList if_handle rn_mod >>
ifaceFixities if_handle rn_mod >>
ifaceInstanceModules if_handle instance_modules >>
-- ******* TYPECHECKER
show_pass "TypeCheck" `thenMn_`
show_pass "TypeCheck" >>
case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
......@@ -146,24 +139,24 @@ doIt (core_cmds, stg_cmds) input_pgm
of { (tc_errs_bag, tc_warns_bag, tc_results) ->
if (not (isEmptyBag tc_errs_bag)) then
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
`thenMn_` writeMn stderr "\n" `thenMn_`
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
`thenMn_` writeMn stderr "\n" `thenMn_`