Commit f23ba2b2 authored by simonpj's avatar simonpj

[project @ 2000-11-10 15:12:50 by simonpj]

1.	Outputable.PprStyle now carries a bit more information
	In particular, the printing style tells whether to print
	a name in unqualified form.  This used to be embedded in
	a Name, but since Names now outlive a single compilation unit,
	that's no longer appropriate.

	So now the print-unqualified predicate is passed in the printing
	style, not embedded in the Name.

   2.	I tidied up HscMain a little.  Many of the showPass messages
	have migraged into the repective pass drivers
parent 6bd12a0c
......@@ -43,8 +43,7 @@ module Name (
#include "HsVersions.h"
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule,
printModulePrefix, isModuleInThisPackage )
import Module ( Module, moduleName, mkVanillaModule, isModuleInThisPackage )
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
......@@ -456,10 +455,10 @@ instance Outputable Name where
-- When printing interfaces, all Locals have been given nice print-names
ppr name = pprName name
pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
= getPprStyle $ \ sty ->
case sort of
Global mod -> pprGlobal sty uniq mod occ
Global mod -> pprGlobal sty name uniq mod occ
System -> pprSysLocal sty uniq occ
Local -> pprLocal sty uniq occ empty
Exported -> pprLocal sty uniq occ (char 'x')
......@@ -470,16 +469,14 @@ pprLocal sty uniq occ pp_export
text "{-" <> pp_export <+> pprUnique10 uniq <> text "-}"
| otherwise = pprOccName occ
pprGlobal sty uniq mod occ
| codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
pprGlobal sty name uniq mod occ
| codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
| debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
| debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
text "{-" <> pprUnique10 uniq <> text "-}"
| ifaceStyle sty
|| printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ
| otherwise = pprOccName occ
| unqualStyle sty name = pprOccName occ
| otherwise = ppr (moduleName mod) <> dot <> pprOccName occ
pprSysLocal sty uniq occ
| codeStyle sty = pprUnique uniq
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.48 2000/11/07 15:21:39 simonmar Exp $
% $Id: CgCase.lhs,v 1.49 2000/11/10 15:12:51 simonpj Exp $
%
%********************************************************
%* *
......@@ -402,7 +402,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
[ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
_ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
| otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
| otherwise = pprPanic "getPrimAppResultAmodes: case of primop has strange type:" (ppr ty)
where (tycon, _, _) = splitAlgTyConApp ty
......
......@@ -40,7 +40,7 @@ import PrimRep ( PrimRep(..) )
import TyCon ( TyCon, isDataTyCon )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
\end{code}
......@@ -60,26 +60,28 @@ codeGen :: DynFlags
codeGen dflags mod_name imported_modules cost_centre_info fe_binders
tycons stg_binds
= mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
let
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
init_stuff = mkModuleInit fe_binders mod_name imported_modules
cost_centre_info
abstractC = mkAbstractCs [ maybe_split,
init_stuff,
code_stuff,
datatype_stuff]
= do { showPass dflags "CodeGen"
; fl_uniqs <- mkSplitUniqSupply 'f'
; let
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
init_stuff = mkModuleInit fe_binders mod_name imported_modules
cost_centre_info
abstractC = mkAbstractCs [ maybe_split,
init_stuff,
code_stuff,
datatype_stuff]
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types)
-- to (say) PrelBase_True_closure, which is defined in code_stuff
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >>
return flat_abstractC
flat_abstractC = flattenAbsC fl_uniqs abstractC
; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
; return flat_abstractC
}
where
data_tycons = filter isDataTyCon tycons
......
......@@ -7,7 +7,7 @@
module CoreLint (
lintCoreBindings,
lintUnfolding,
beginPass, endPass, endPassWithRules
showPass, endPass, endPassWithRules
) where
#include "HsVersions.h"
......@@ -27,7 +27,7 @@ import VarSet
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message,
import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, showPass,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc )
......@@ -58,14 +58,6 @@ place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
beginPass :: DynFlags -> String -> IO ()
beginPass dflags pass_name
| dopt Opt_D_show_passes dflags
= hPutStrLn stdout ("*** " ++ pass_name)
| otherwise
= return ()
endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass dflags pass_name dump_flag binds
= do
......
......@@ -14,7 +14,7 @@ module CoreTidy (
import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
import CoreLint ( showPass, endPass )
import UsageSPInf ( doUsageSPInf )
import VarEnv
import VarSet
......@@ -35,6 +35,7 @@ import Type ( tidyTopType, tidyType, tidyTyVar )
import Module ( Module )
import UniqSupply ( mkSplitUniqSupply )
import Unique ( Uniquable(..) )
import ErrUtils ( showPass )
import SrcLoc ( noSrcLoc )
import Util ( mapAccumL )
\end{code}
......@@ -72,7 +73,7 @@ tidyCorePgm dflags module_name binds_in orphans_in
= do
us <- mkSplitUniqSupply 'u'
beginPass dflags "Tidy Core"
showPass dflags "Tidy Core"
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
......
......@@ -7,7 +7,7 @@ module CprAnalyse ( cprAnalyse ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreLint ( beginPass, endPass )
import CoreLint ( showPass, endPass )
import CoreSyn
import CoreUtils ( exprIsValue )
import Id ( Id, setIdCprInfo, idCprInfo, idArity,
......@@ -137,7 +137,7 @@ ids decorated with their CprInfo pragmas.
cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
cprAnalyse dflags binds
= do {
beginPass dflags "Constructed Product analysis" ;
showPass dflags "Constructed Product analysis" ;
let { binds_plus_cpr = do_prog binds } ;
endPass dflags "Constructed Product analysis"
(dopt Opt_D_dump_cpranal dflags || dopt Opt_D_verbose_core2core dflags)
......
......@@ -28,10 +28,10 @@ import Id ( Id )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
import CoreLint ( beginPass, endPass )
import CoreLint ( showPass, endPass )
import ErrUtils ( doIfSet, pprBagOfWarnings )
import Outputable
import UniqSupply ( UniqSupply )
import UniqSupply ( mkSplitUniqSupply )
import HscTypes ( HomeSymbolTable )
\end{code}
......@@ -46,34 +46,36 @@ start.
\begin{code}
deSugar :: DynFlags
-> Module
-> UniqSupply
-> Module -> PrintUnqualified
-> HomeSymbolTable
-> TcResults
-> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
deSugar dflags mod_name us hst
deSugar dflags mod_name unqual hst
(TcResults {tc_env = global_val_env,
tc_pcs = pcs,
tc_binds = all_binds,
tc_rules = rules,
tc_fords = fo_decls})
= do
beginPass dflags "Desugar"
showPass dflags "Desugar"
us <- mkSplitUniqSupply 'd'
-- Do desugaring
let (result, ds_warns) =
initDs dflags us (hst,pcs,global_val_env) mod_name
(dsProgram mod_name all_binds rules fo_decls)
(ds_binds, ds_rules, _, _, _) = result
-- Display any warnings
-- Display any warnings
doIfSet (not (isEmptyBag ds_warns))
(printErrs (pprBagOfWarnings ds_warns))
(printErrs unqual (pprBagOfWarnings ds_warns))
-- Lint result if necessary
-- Lint result if necessary
let do_dump_ds = dopt Opt_D_dump_ds dflags
endPass dflags "Desugar" do_dump_ds ds_binds
-- Dump output
doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
return result
......
......@@ -108,7 +108,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
| otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
= dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
= dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
= case pp_match kind pats of
......
......@@ -74,16 +74,18 @@ instance (Outputable pat, Outputable id) =>
ppr_binds EmptyBinds = empty
ppr_binds (ThenBinds binds1 binds2)
= ($$) (ppr_binds binds1) (ppr_binds binds2)
= ppr_binds binds1 $$ ppr_binds binds2
ppr_binds (MonoBind bind sigs is_rec)
= vcat [ifNotPprForUser (ptext rec_str),
= vcat [ppr_isrec,
vcat (map ppr sigs),
ppr bind
]
where
rec_str = case is_rec of
Recursive -> SLIT("{- rec -}")
NonRecursive -> SLIT("{- nonrec -}")
ppr_isrec = getPprStyle $ \ sty ->
if userStyle sty then empty else
case is_rec of
Recursive -> ptext SLIT("{- rec -}")
NonRecursive -> ptext SLIT("{- nonrec -}")
\end{code}
%************************************************************************
......
......@@ -19,7 +19,7 @@ import HsTypes ( HsType )
-- others:
import Name ( Name, isLexSym )
import Outputable
import PprType ( pprType, pprParendType )
import PprType ( pprParendType )
import Type ( Type )
import Var ( TyVar )
import DataCon ( DataCon )
......@@ -305,8 +305,7 @@ ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList exprs)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitListOut ty exprs)
= hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
ifNotPprForUser ((<>) space (parens (pprType ty))) ]
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (sep (punctuate comma (map ppr_expr exprs)))
......@@ -394,7 +393,7 @@ pprParendExpr expr
\begin{code}
isOperator :: Outputable a => a -> Bool
isOperator v = isLexSym (_PK_ (showSDoc (ppr v)))
isOperator v = isLexSym (_PK_ (showSDocUnqual (ppr v)))
-- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so
-- that we don't need NamedThing in the context of all these functions.
-- Gruesome, but simple.
......
......@@ -27,7 +27,7 @@ import AbsCSyn ( AbstractC )
import PprAbsC ( dumpRealC, writeRealC )
import Module ( Module )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
import TmpFiles ( newTempName )
......@@ -61,16 +61,18 @@ codeOutput dflags mod_name tycons core_binds stg_binds
-- Dunno if the above comment is still meaningful now. JRS 001024.
do let filenm = dopt_OutName dflags
stub_names <- outputForeignStubs dflags c_code h_code
case dopt_HscLang dflags of
HscInterpreted -> return stub_names
HscAsm -> outputAsm dflags filenm flat_abstractC
>> return stub_names
HscC -> outputC dflags filenm flat_abstractC
>> return stub_names
HscJava -> outputJava dflags filenm mod_name tycons core_binds
>> return stub_names
do { showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
; stub_names <- outputForeignStubs dflags c_code h_code
; case dopt_HscLang dflags of
HscInterpreted -> return stub_names
HscAsm -> outputAsm dflags filenm flat_abstractC
>> return stub_names
HscC -> outputC dflags filenm flat_abstractC
>> return stub_names
HscJava -> outputJava dflags filenm mod_name tycons core_binds
>> return stub_names
}
doOutput :: String -> (Handle -> IO ()) -> IO ()
doOutput filenm io_action
......@@ -130,7 +132,7 @@ outputAsm dflags filenm flat_absC
\begin{code}
outputJava dflags filenm mod tycons core_binds
= doOutput filenm (\ f -> printForUser f pp_java)
= doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
-- User style printing for now to keep indentation
where
java_code = javaGen mod [{- Should be imports-}] tycons core_binds
......
......@@ -5,22 +5,24 @@
\begin{code}
module ErrUtils (
ErrMsg, WarnMsg, Message,
ErrMsg, WarnMsg, Message, Messages, errorsFound,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine,
dontAddErrLoc,
addErrLocHdrLine, dontAddErrLoc,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn
doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn, showPass
) where
#include "HsVersions.h"
import Bag ( Bag, bagToList, isEmptyBag )
import SrcLoc ( SrcLoc, noSrcLoc )
import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc )
import Util ( sortLt )
import Outputable
import CmdLineOpts ( DynFlags, DynFlag, dopt )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import System ( ExitCode(..), exitWith )
import IO ( hPutStr, stderr )
......@@ -38,10 +40,9 @@ addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg
addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
addShortErrLocLine locn rest_of_err_msg
= ( locn
, hang (ppr locn <> colon)
4 rest_of_err_msg
)
| isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
rest_of_err_msg)
| otherwise = (locn, rest_of_err_msg)
addErrLocHdrLine locn hdr rest_of_err_msg
= ( locn
......@@ -50,23 +51,28 @@ addErrLocHdrLine locn hdr rest_of_err_msg
)
addShortWarnLocLine locn rest_of_err_msg
= ( locn
, hang (ppr locn <> colon)
4 (ptext SLIT("Warning:") <+> rest_of_err_msg)
)
| isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
(ptext SLIT("Warning:") <+> rest_of_err_msg))
| otherwise = (locn, rest_of_err_msg)
dontAddErrLoc :: String -> Message -> ErrMsg
dontAddErrLoc title rest_of_err_msg
| null title = (noSrcLoc, rest_of_err_msg)
| otherwise =
( noSrcLoc, hang (text title <> colon) 4 rest_of_err_msg )
dontAddErrLoc :: Message -> ErrMsg
dontAddErrLoc msg = (noSrcLoc, msg)
printErrorsAndWarnings :: (Bag WarnMsg, Bag ErrMsg) -> IO ()
\end{code}
\begin{code}
type Messages = (Bag WarnMsg, Bag ErrMsg)
errorsFound :: Messages -> Bool
errorsFound (warns, errs) = not (isEmptyBag errs)
printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
-- Don't print any warnings if there are errors
printErrorsAndWarnings (warns, errs)
printErrorsAndWarnings unqual (warns, errs)
| no_errs && no_warns = return ()
| no_errs = printErrs (pprBagOfWarnings warns)
| otherwise = printErrs (pprBagOfErrors errs)
| no_errs = printErrs unqual (pprBagOfWarnings warns)
| otherwise = printErrs unqual (pprBagOfErrors errs)
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
......@@ -103,6 +109,11 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
\end{code}
\begin{code}
showPass :: DynFlags -> String -> IO ()
showPass dflags what
| dopt Opt_D_show_passes dflags = hPutStr stderr ("*** "++what++":\n")
| otherwise = return ()
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
| not flag = return ()
......
......@@ -10,7 +10,7 @@ module HscMain ( HscResult(..), hscMain,
#include "HsVersions.h"
import Maybe ( isJust )
import IO ( hPutStr, hPutStrLn, stderr )
import IO ( hPutStrLn, stderr )
import HsSyn
import StringBuffer ( hGetStringBuffer )
......@@ -39,7 +39,7 @@ import CodeOutput ( codeOutput )
import Module ( ModuleName, moduleName, mkModuleInThisPackage )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
......@@ -93,10 +93,11 @@ hscMain
hscMain dflags source_unchanged location maybe_old_iface hst hit pcs
= do {
putStrLn "CHECKING OLD IFACE";
(pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface))
(pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface))
<- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain")
source_unchanged maybe_old_iface;
if check_errs then
if errs_found then
return (HscFail pcs_ch)
else do {
......@@ -126,8 +127,8 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
else do {
-- TYPECHECK
maybe_tc_result
<- typecheckModule dflags this_mod pcs_cl hst old_iface cl_hs_decls;
maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst
old_iface alwaysQualify cl_hs_decls;
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
Just tc_result -> do {
......@@ -149,71 +150,81 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
= do {
hPutStrLn stderr "COMPILATION IS REQUIRED";
-- what target are we shooting for?
let toInterp = dopt_HscLang dflags == HscInterpreted
;
-- PARSE
maybe_parsed
<- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp");
case maybe_parsed of {
Nothing -> return (HscFail pcs_ch);
Just rdr_module -> do {
-- RENAME
let this_mod = mkModuleInThisPackage (hsModuleName rdr_module)
;
show_pass dflags "Renamer";
(pcs_rn, maybe_rn_result)
<- renameModule dflags hit hst pcs_ch this_mod rdr_module;
case maybe_rn_result of {
Nothing -> return (HscFail pcs_rn);
Just (new_iface, rn_hs_decls) -> do {
-- TYPECHECK
show_pass dflags "Typechecker";
maybe_tc_result
<- typecheckModule dflags this_mod pcs_rn hst new_iface rn_hs_decls;
case maybe_tc_result of {
Nothing -> do { hPutStrLn stderr "Typechecked failed"
; return (HscFail pcs_rn) } ;
Just tc_result -> do {
let pcs_tc = tc_pcs tc_result
env_tc = tc_env tc_result
local_insts = tc_insts tc_result
;
-- DESUGAR, SIMPLIFY, TIDY-CORE
-- We grab the the unfoldings at this point.
(tidy_binds, orphan_rules, foreign_stuff)
<- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod tc_result hst
;
-- CONVERT TO STG
(stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids)
<- myCoreToStg dflags this_mod tidy_binds
;
-- cook up a new ModDetails now we (finally) have all the bits
let new_details = mkModDetails env_tc local_insts tidy_binds
top_level_ids orphan_rules
;
-- and the final interface
final_iface
<- mkFinalIface dflags location maybe_checked_iface new_iface new_details
;
-- do the rest of code generation/emission
(maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
<- restOfCodeGeneration dflags toInterp this_mod
(map ideclName (hsModuleImports rdr_module))
cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
hit (pcs_PIT pcs_tc)
;
-- and the answer is ...
return (HscOK new_details (Just final_iface)
maybe_stub_h_filename maybe_stub_c_filename
maybe_ibinds pcs_tc)
}}}}}}}
= do {
; hPutStrLn stderr "COMPILATION IS REQUIRED";
-- what target are we shooting for?
; let toInterp = dopt_HscLang dflags == HscInterpreted
-------------------
-- PARSE
-------------------
; maybe_parsed <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp")
; case maybe_parsed of {
Nothing -> return (HscFail pcs_ch);
Just rdr_module -> do {
; let this_mod = mkModuleInThisPackage (hsModuleName rdr_module)
-------------------
-- RENAME
-------------------
; (pcs_rn, maybe_rn_result)
<- renameModule dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
Nothing -> return (HscFail pcs_rn);
Just (print_unqualified, new_iface, rn_hs_decls) -> do {
-------------------
-- TYPECHECK
-------------------
; maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst new_iface
print_unqualified rn_hs_decls
; case maybe_tc_result of {
Nothing -> do { hPutStrLn stderr "Typechecked failed"
; return (HscFail pcs_rn) } ;
Just tc_result -> do {
; let pcs_tc = tc_pcs tc_result
env_tc = tc_env tc_result
local_insts = tc_insts tc_result
-------------------
-- DESUGAR, SIMPLIFY, TIDY-CORE
-------------------
-- We grab the the unfoldings at this point.
; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod
print_unqualified tc_result hst
; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
-------------------
-- CONVERT TO STG
-------------------
; (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids)
<- myCoreToStg dflags this_mod tidy_binds
-------------------
-- BUILD THE NEW ModDetails AND ModIface
-------------------
; let new_details = mkModDetails env_tc local_insts tidy_binds
top_level_ids orphan_rules
; final_iface <- mkFinalIface dflags location maybe_checked_iface
new_iface new_details
-------------------
-- COMPLETE CODE GENERATION
-------------------
; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
<- restOfCodeGeneration dflags toInterp this_mod
(map ideclName (hsModuleImports rdr_module))
cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
hit (pcs_PIT pcs_tc)
-- and the answer is ...
; return (HscOK new_details (Just final_iface)
maybe_stub_h_filename maybe_stub_c_filename
maybe_ibinds pcs_tc)
}}}}}}}
......@@ -233,7 +244,7 @@ mkFinalIface dflags location maybe_old_iface new_iface new_details
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
show_pass dflags "Parser"
showPass dflags "Parser"
-- _scc_ "Parser"
buf <- hGetStringBuffer True{-expand tabs-} src_filename
......@@ -268,14 +279,12 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
| otherwise
= do -------------------------- Code generation -------------------------------
show_pass dflags "CodeGen"
-- _scc_ "CodeGen"
abstractC <- codeGen dflags this_mod imported_modules
cost_centre_info fe_binders
local_tycons stg_binds