Commit de896403 authored by simonmar's avatar simonmar

[project @ 2000-03-08 17:48:24 by simonmar]

- generalise the per-module initialisation stubs so that we use it
  in normal (non-profiled) code too.  The initialisation stubs are
  now called '__init_<module>' rather than '_reg<module>'.

- Register foreign exported functions as stable pointers in the
  initialisation code for the module.  This fixes the foreign export
  problems reported by several people.

- remove the concept of "module groups" from the profiling subsystem.

- change the profiling semantics slightly; it should be unnecessary
  to use '-caf-all' to get reasonable profiles now.
parent 54e6a4e1
% %
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
% %
% $Id: AbsCSyn.lhs,v 1.26 1999/11/02 15:05:39 simonmar Exp $ % $Id: AbsCSyn.lhs,v 1.27 2000/03/08 17:48:24 simonmar Exp $
% %
\section[AbstractC]{Abstract C: the last stop before machine code} \section[AbstractC]{Abstract C: the last stop before machine code}
...@@ -201,6 +201,10 @@ stored in a mixed type location.) ...@@ -201,6 +201,10 @@ stored in a mixed type location.)
| CClosureTbl -- table of constructors for enumerated types | CClosureTbl -- table of constructors for enumerated types
TyCon -- which TyCon this table is for TyCon -- which TyCon this table is for
| CModuleInitBlock -- module initialisation block
CAddrMode -- label for init block
AbstractC -- initialisation code
| CCostCentreDecl -- A cost centre *declaration* | CCostCentreDecl -- A cost centre *declaration*
Bool -- True <=> local => full declaration Bool -- True <=> local => full declaration
-- False <=> extern; just say so -- False <=> extern; just say so
...@@ -235,6 +239,10 @@ data CStmtMacro ...@@ -235,6 +239,10 @@ data CStmtMacro
| PUSH_SEQ_FRAME -- push seq frame | PUSH_SEQ_FRAME -- push seq frame
| UPDATE_SU_FROM_UPD_FRAME -- pull Su out of the update frame | UPDATE_SU_FROM_UPD_FRAME -- pull Su out of the update frame
| SET_TAG -- set TagReg if it exists | SET_TAG -- set TagReg if it exists
| REGISTER_FOREIGN_EXPORT -- register a foreign exported fun
| REGISTER_IMPORT -- register an imported module
| GRAN_FETCH -- for GrAnSim only -- HWL | GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL | GRAN_RESCHEDULE -- for GrAnSim only -- HWL
| GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
......
...@@ -376,6 +376,7 @@ flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt) ...@@ -376,6 +376,7 @@ flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -563,6 +563,14 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ ...@@ -563,6 +563,14 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
LvLarge _ -> SLIT("RET_VEC_BIG") LvLarge _ -> SLIT("RET_VEC_BIG")
pprAbsC stmt@(CModuleInitBlock label code) _
= vcat [
ptext SLIT("START_MOD_INIT") <> parens (ppr_amode label),
case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
pprAbsC code (costs code),
hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
]
pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code} \end{code}
...@@ -1157,6 +1165,8 @@ cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME") ...@@ -1157,6 +1165,8 @@ cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME")
cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME") cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME") cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG") cStmtMacroText SET_TAG = SLIT("SET_TAG")
cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH") cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH")
cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE") cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE")
cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE") cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
...@@ -1511,6 +1521,9 @@ ppr_decls_AbsC (CSRT lbl closure_lbls) ...@@ -1511,6 +1521,9 @@ ppr_decls_AbsC (CSRT lbl closure_lbls)
ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
ppr_decls_AbsC (CModuleInitBlock _ code) = ppr_decls_AbsC code
ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -32,12 +32,13 @@ import CgCon ( cgTopRhsCon ) ...@@ -32,12 +32,13 @@ import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits ) import CgConTbls ( genStaticConBits )
import ClosureInfo ( mkClosureLFInfo ) import ClosureInfo ( mkClosureLFInfo )
import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC,
opt_D_dump_absC, opt_SccGroup opt_D_dump_absC
) )
import CostCentre ( CostCentre, CostCentreStack ) import CostCentre ( CostCentre, CostCentreStack )
import FiniteMap ( FiniteMap ) import FiniteMap ( FiniteMap )
import Id ( Id, idName ) import Id ( Id, idName )
import Module ( Module, moduleString, ModuleName, moduleNameString ) import Module ( Module, moduleString, moduleName,
ModuleName, moduleNameString )
import PrimRep ( getPrimRepSize, PrimRep(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) )
import Type ( Type ) import Type ( Type )
import TyCon ( TyCon, isDataTyCon ) import TyCon ( TyCon, isDataTyCon )
...@@ -57,19 +58,21 @@ codeGen :: Module -- Module name ...@@ -57,19 +58,21 @@ codeGen :: Module -- Module name
-> ([CostCentre], -- Local cost-centres needing declaring/registering -> ([CostCentre], -- Local cost-centres needing declaring/registering
[CostCentre], -- "extern" cost-centres needing declaring [CostCentre], -- "extern" cost-centres needing declaring
[CostCentreStack]) -- Pre-defined "singleton" cost centre stacks [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks
-> [Id] -- foreign-exported binders
-> [TyCon] -> [Class] -- Local tycons and classes -> [TyCon] -> [Class] -- Local tycons and classes
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output -> IO AbstractC -- Output
codeGen mod_name imported_modules cost_centre_info codeGen mod_name imported_modules cost_centre_info fe_binders
tycons classes stg_binds tycons classes stg_binds
= mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener = mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
let let
datatype_stuff = genStaticConBits cinfo data_tycons datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds) code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
cost_centre_stuff = mkCostCentreStuff mod_name imported_modules cost_centre_info init_stuff = mkModuleInit fe_binders mod_name imported_modules
cost_centre_info
abstractC = mkAbstractCs [ cost_centre_stuff, abstractC = mkAbstractCs [ init_stuff,
datatype_stuff, datatype_stuff,
code_stuff ] code_stuff ]
...@@ -89,52 +92,77 @@ codeGen mod_name imported_modules cost_centre_info ...@@ -89,52 +92,77 @@ codeGen mod_name imported_modules cost_centre_info
cinfo = MkCompInfo mod_name cinfo = MkCompInfo mod_name
\end{code} \end{code}
Cost-centre profiling: %************************************************************************
Besides the usual stuff, we must produce: %* *
\subsection[codegen-init]{Module initialisation code}
%* *
%************************************************************************
* Declarations for the cost-centres defined in this module; \begin{code}
* Code to participate in "registering" all the cost-centres mkModuleInit
in the program (done at startup time when the pgm is run). :: [Id] -- foreign exported functions
-> Module -- module name
-> [ModuleName] -- import names
-> ([CostCentre], -- cost centre info
[CostCentre],
[CostCentreStack])
-> AbstractC
mkModuleInit fe_binders mod imps cost_centre_info
= let
register_fes =
map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
fe_labels =
map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
mk_reg_lbl mod_name
= CLitLit (_PK_ ("__init_" ++ moduleNameString mod_name)) AddrRep
(The local cost-centres involved in this are passed mk_import_register import_name
into the code-generator, as are the imported-modules' names.) = CMacroStmt REGISTER_IMPORT [mk_reg_lbl import_name]
\begin{code} register_imports = map mk_import_register imps
mkCostCentreStuff mod_name import_names (local_CCs, extern_CCs, singleton_CCSs) in
| not opt_SccProfilingOn = AbsCNop mkAbstractCs [
| otherwise = mkAbstractCs ( cc_decls,
map (CCostCentreDecl True) local_CCs ++ CModuleInitBlock (mk_reg_lbl (Module.moduleName mod))
map (CCostCentreDecl False) extern_CCs ++ (mkAbstractCs (register_fes ++
map CCostCentreStackDecl singleton_CCSs ++ cc_regs :
mkCcRegister local_CCs singleton_CCSs import_names register_imports))
) ]
\end{code}
Cost-centre profiling: Besides the usual stuff, we must produce
declarations for the cost-centres defined in this module;
(The local cost-centres involved in this are passed into the
code-generator.)
\begin{code}
mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
| not opt_SccProfilingOn = (AbsCNop, AbsCNop)
| otherwise =
( mkAbstractCs (
map (CCostCentreDecl True) local_CCs ++
map (CCostCentreDecl False) extern_CCs ++
map CCostCentreStackDecl singleton_CCSs),
mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
)
where where
mkCcRegister ccs cc_stacks import_names mkCcRegister ccs cc_stacks
= let = let
register_ccs = mkAbstractCs (map mk_register ccs) register_ccs = mkAbstractCs (map mk_register ccs)
register_imports
= foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names
register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks) register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
in in
[ [ register_ccs, register_cc_stacks ]
CCallProfCCMacro SLIT("START_REGISTER_CCS")
[ CLitLit (_PK_ ("_reg" ++ moduleString mod_name)) AddrRep],
register_ccs,
register_cc_stacks,
register_imports,
CCallProfCCMacro SLIT("END_REGISTER_CCS") []
]
where where
mk_register cc mk_register cc
= CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc] = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
mk_register_ccs ccs mk_register_ccs ccs
= CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs] = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
mk_import_register import_name
= CCallProfCCMacro SLIT("REGISTER_IMPORT")
[CLitLit (_PK_ ("_reg" ++ moduleNameString import_name)) AddrRep]
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -29,7 +29,7 @@ import Name ( isLocallyDefined ) ...@@ -29,7 +29,7 @@ import Name ( isLocallyDefined )
import VarEnv import VarEnv
import VarSet import VarSet
import Bag ( isEmptyBag, unionBags ) import Bag ( isEmptyBag, unionBags )
import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn ) import CmdLineOpts ( opt_SccProfilingOn )
import CoreLint ( beginPass, endPass ) import CoreLint ( beginPass, endPass )
import ErrUtils ( doIfSet, pprBagOfWarnings ) import ErrUtils ( doIfSet, pprBagOfWarnings )
import Outputable import Outputable
...@@ -49,7 +49,7 @@ start. ...@@ -49,7 +49,7 @@ start.
deSugar :: Module deSugar :: Module
-> UniqSupply -> UniqSupply
-> TcResults -> TcResults
-> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc) -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr])
deSugar mod_name us (TcResults {tc_env = global_val_env, deSugar mod_name us (TcResults {tc_env = global_val_env,
tc_binds = all_binds, tc_binds = all_binds,
...@@ -58,9 +58,10 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, ...@@ -58,9 +58,10 @@ deSugar mod_name us (TcResults {tc_env = global_val_env,
= do = do
beginPass "Desugar" beginPass "Desugar"
-- Do desugaring -- Do desugaring
let (result, ds_warns) = initDs us global_val_env module_and_group let (result, ds_warns) =
(dsProgram mod_name all_binds rules fo_decls) initDs us global_val_env mod_name
(ds_binds, ds_rules, _, _) = result (dsProgram mod_name all_binds rules fo_decls)
(ds_binds, ds_rules, _, _, _) = result
-- Display any warnings -- Display any warnings
doIfSet (not (isEmptyBag ds_warns)) doIfSet (not (isEmptyBag ds_warns))
...@@ -72,11 +73,6 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, ...@@ -72,11 +73,6 @@ deSugar mod_name us (TcResults {tc_env = global_val_env,
doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules)) doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules))
return result return result
where
module_and_group = (mod_name, grp_name)
grp_name = case opt_SccGroup of
Just xx -> _PK_ xx
Nothing -> _PK_ (moduleString mod_name) -- default: module name
dsProgram mod_name all_binds rules fo_decls dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
...@@ -84,8 +80,9 @@ dsProgram mod_name all_binds rules fo_decls ...@@ -84,8 +80,9 @@ dsProgram mod_name all_binds rules fo_decls
mapDs dsRule rules `thenDs` \ rules' -> mapDs dsRule rules `thenDs` \ rules' ->
let let
ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
fe_binders = bindersOfBinds fe_binds
in in
returnDs (ds_binds, rules', h_code, c_code) returnDs (ds_binds, rules', h_code, c_code, fe_binders)
where where
auto_scc | opt_SccProfilingOn = TopLevel auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs | otherwise = NoSccs
......
...@@ -205,8 +205,8 @@ addAutoScc :: AutoScc -- if needs be, decorate toplevs? ...@@ -205,8 +205,8 @@ addAutoScc :: AutoScc -- if needs be, decorate toplevs?
addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr)
| do_auto_scc && worthSCC core_expr | do_auto_scc && worthSCC core_expr
= getModuleAndGroupDs `thenDs` \ (mod,grp) -> = getModuleDs `thenDs` \ mod ->
returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod grp NotCafCC)) core_expr) returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod NotCafCC)) core_expr)
where do_auto_scc = isJust maybe_auto_scc where do_auto_scc = isJust maybe_auto_scc
maybe_auto_scc = auto_scc_fn bndr maybe_auto_scc = auto_scc_fn bndr
(Just top_bndr) = maybe_auto_scc (Just top_bndr) = maybe_auto_scc
......
...@@ -296,8 +296,8 @@ dsExpr (CCall lbl args may_gc is_asm result_ty) ...@@ -296,8 +296,8 @@ dsExpr (CCall lbl args may_gc is_asm result_ty)
dsExpr (HsSCC cc expr) dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr -> = dsExpr expr `thenDs` \ core_expr ->
getModuleAndGroupDs `thenDs` \ (mod_name, group_name) -> getModuleDs `thenDs` \ mod_name ->
returnDs (Note (SCC (mkUserCC cc mod_name group_name)) core_expr) returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
-- special case to handle unboxed tuple patterns. -- special case to handle unboxed tuple patterns.
......
...@@ -287,7 +287,7 @@ dsFExport i ty mod_name ext_name cconv isDyn = ...@@ -287,7 +287,7 @@ dsFExport i ty mod_name ext_name cconv isDyn =
getFun_wrapper $ getFun_wrapper $
mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args) mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args)
in in
getModuleAndGroupDs `thenDs` \ (mod,_) -> getModuleDs `thenDs` \ mod ->
getUniqueDs `thenDs` \ uniq -> getUniqueDs `thenDs` \ uniq ->
let let
the_body = mkLams (tvs ++ wrapper_args) the_app the_body = mkLams (tvs ++ wrapper_args) the_app
......
...@@ -13,7 +13,7 @@ module DsMonad ( ...@@ -13,7 +13,7 @@ module DsMonad (
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
newFailLocalDs, newFailLocalDs,
getSrcLocDs, putSrcLocDs, getSrcLocDs, putSrcLocDs,
getModuleAndGroupDs, getModuleDs,
getUniqueDs, getUniqueDs,
dsLookupGlobalValue, dsLookupGlobalValue,
...@@ -55,15 +55,13 @@ type DsM result = ...@@ -55,15 +55,13 @@ type DsM result =
UniqSupply UniqSupply
-> ValueEnv -> ValueEnv
-> SrcLoc -- to put in pattern-matching error msgs -> SrcLoc -- to put in pattern-matching error msgs
-> (Module, Group) -- module + group name : for SCC profiling -> Module -- module: for SCC profiling
-> DsWarnings -> DsWarnings
-> (result, DsWarnings) -> (result, DsWarnings)
type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are
-- completely shadowed or incomplete patterns -- completely shadowed or incomplete patterns
type Group = FAST_STRING
{-# INLINE andDs #-} {-# INLINE andDs #-}
{-# INLINE thenDs #-} {-# INLINE thenDs #-}
{-# INLINE returnDs #-} {-# INLINE returnDs #-}
...@@ -72,29 +70,29 @@ type Group = FAST_STRING ...@@ -72,29 +70,29 @@ type Group = FAST_STRING
initDs :: UniqSupply initDs :: UniqSupply
-> ValueEnv -> ValueEnv
-> (Module, Group) -- module name: for profiling; (group name: from switches) -> Module -- module name: for profiling
-> DsM a -> DsM a
-> (a, DsWarnings) -> (a, DsWarnings)
initDs init_us genv module_and_group action initDs init_us genv mod action
= action init_us genv noSrcLoc module_and_group emptyBag = action init_us genv noSrcLoc mod emptyBag
thenDs :: DsM a -> (a -> DsM b) -> DsM b thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
thenDs m1 m2 us genv loc mod_and_grp warns thenDs m1 m2 us genv loc mod warns
= case splitUniqSupply us of { (s1, s2) -> = case splitUniqSupply us of { (s1, s2) ->
case (m1 s1 genv loc mod_and_grp warns) of { (result, warns1) -> case (m1 s1 genv loc mod warns) of { (result, warns1) ->
m2 result s2 genv loc mod_and_grp warns1}} m2 result s2 genv loc mod warns1}}
andDs combiner m1 m2 us genv loc mod_and_grp warns andDs combiner m1 m2 us genv loc mod warns
= case splitUniqSupply us of { (s1, s2) -> = case splitUniqSupply us of { (s1, s2) ->
case (m1 s1 genv loc mod_and_grp warns) of { (result1, warns1) -> case (m1 s1 genv loc mod warns) of { (result1, warns1) ->
case (m2 s2 genv loc mod_and_grp warns1) of { (result2, warns2) -> case (m2 s2 genv loc mod warns1) of { (result2, warns2) ->
(combiner result1 result2, warns2) }}} (combiner result1 result2, warns2) }}}
returnDs :: a -> DsM a returnDs :: a -> DsM a
returnDs result us genv loc mod_and_grp warns = (result, warns) returnDs result us genv loc mod warns = (result, warns)
listDs :: [DsM a] -> DsM [a] listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs [] listDs [] = returnDs []
...@@ -141,29 +139,29 @@ it easier to read debugging output. ...@@ -141,29 +139,29 @@ it easier to read debugging output.
\begin{code} \begin{code}
newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDs ty us genv loc mod_and_grp warns newSysLocalDs ty us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq -> = case uniqFromSupply us of { assigned_uniq ->
(mkSysLocal SLIT("ds") assigned_uniq ty, warns) } (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
newSysLocalsDs tys = mapDs newSysLocalDs tys newSysLocalsDs tys = mapDs newSysLocalDs tys
newFailLocalDs ty us genv loc mod_and_grp warns newFailLocalDs ty us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq -> = case uniqFromSupply us of { assigned_uniq ->
(mkSysLocal SLIT("fail") assigned_uniq ty, warns) } (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
-- The UserLocal bit just helps make the code a little clearer -- The UserLocal bit just helps make the code a little clearer
getUniqueDs :: DsM Unique getUniqueDs :: DsM Unique
getUniqueDs us genv loc mod_and_grp warns getUniqueDs us genv loc mod warns
= case (uniqFromSupply us) of { assigned_uniq -> = case (uniqFromSupply us) of { assigned_uniq ->
(assigned_uniq, warns) } (assigned_uniq, warns) }
duplicateLocalDs :: Id -> DsM Id duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local us genv loc mod_and_grp warns duplicateLocalDs old_local us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq -> = case uniqFromSupply us of { assigned_uniq ->
(setIdUnique old_local assigned_uniq, warns) } (setIdUnique old_local assigned_uniq, warns) }
cloneTyVarsDs :: [TyVar] -> DsM [TyVar] cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
cloneTyVarsDs tyvars us genv loc mod_and_grp warns cloneTyVarsDs tyvars us genv loc mod warns
= case uniqsFromSupply (length tyvars) us of { uniqs -> = case uniqsFromSupply (length tyvars) us of { uniqs ->
(zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) } (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
\end{code} \end{code}
...@@ -171,7 +169,7 @@ cloneTyVarsDs tyvars us genv loc mod_and_grp warns ...@@ -171,7 +169,7 @@ cloneTyVarsDs tyvars us genv loc mod_and_grp warns
\begin{code} \begin{code}
newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs :: [TyVar] -> DsM [TyVar]
newTyVarsDs tyvar_tmpls us genv loc mod_and_grp warns newTyVarsDs tyvar_tmpls us genv loc mod warns
= case uniqsFromSupply (length tyvar_tmpls) us of { uniqs -> = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
(zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) } (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
\end{code} \end{code}
...@@ -181,31 +179,30 @@ the @SrcLoc@ being carried around. ...@@ -181,31 +179,30 @@ the @SrcLoc@ being carried around.
\begin{code} \begin{code}
uniqSMtoDsM :: UniqSM a -> DsM a uniqSMtoDsM :: UniqSM a -> DsM a
uniqSMtoDsM u_action us genv loc mod_and_grp warns uniqSMtoDsM u_action us genv loc mod warns
= (initUs_ us u_action, warns) = (initUs_ us u_action, warns)
getSrcLocDs :: DsM SrcLoc getSrcLocDs :: DsM SrcLoc
getSrcLocDs us genv loc mod_and_grp warns getSrcLocDs us genv loc mod warns
= (loc, warns) = (loc, warns)
putSrcLocDs :: SrcLoc -> DsM a -> DsM a putSrcLocDs :: SrcLoc -> DsM a -> DsM a
putSrcLocDs new_loc expr us genv old_loc mod_and_grp warns putSrcLocDs new_loc expr us genv old_loc mod warns
= expr us genv new_loc mod_and_grp warns = expr us genv new_loc mod warns
dsWarn :: WarnMsg -> DsM () dsWarn :: WarnMsg -> DsM ()
dsWarn warn us genv loc mod_and_grp warns = ((), warns `snocBag` warn) dsWarn warn us genv loc mod warns = ((), warns `snocBag` warn)
\end{code} \end{code}
\begin{code} \begin{code}
getModuleAndGroupDs :: DsM (Module, Group) getModuleDs :: DsM Module
getModuleAndGroupDs us genv loc mod_and_grp warns getModuleDs us genv loc mod warns = (mod, warns)
= (mod_and_grp, warns)
\end{code} \end{code}
\begin{code} \begin{code}
dsLookupGlobalValue :: Name -> DsM Id dsLookupGlobalValue :: Name -> DsM Id
dsLookupGlobalValue name us genv loc mod_and_grp warns dsLookupGlobalValue name us genv loc mod warns
= case maybeWiredInIdName name of = case maybeWiredInIdName name of
Just id -> (id, warns) Just id -> (id, warns)
Nothing -> (lookupWithDefaultUFM genv def name, warns) Nothing -> (lookupWithDefaultUFM genv def name, warns)
......
...@@ -75,7 +75,6 @@ module CmdLineOpts ( ...@@ -75,7 +75,6 @@ module CmdLineOpts (
opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs, opt_AutoSccsOnIndividualCafs,
opt_AutoSccsOnDicts, opt_AutoSccsOnDicts,