Skip to content

GitLab

GHC
GHC
Commit 8b653a82 authored by simonpj's avatar simonpj
Browse files
Options

[project @ 2000-11-15 14:37:08 by simonpj] 

The main thing in this commit is to change StgAlts so that
it carries a TyCon, and not a Type.  Furthermore, the TyCon
is derived from the alternatives, so it should have its
constructors etc, even if there's a module loop involved, so that
some versions of the TyCon don't have the constructors visible.

There's a comment in StgSyn.lhs, with the type decl for StgAlts


Also: a start on hscExpr in HscMain.
parent 4631557d
Hide whitespace changes
Inline Side-by-side
Showing with 297 additions and 265 deletions
ghc/compiler/codeGen/CgCase.lhs
View file @ 8b653a82
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.49 2000/11/10 15:12:51 simonpj Exp $
% $Id: CgCase.lhs,v 1.50 2000/11/15 14:37:08 simonpj Exp $
%
%********************************************************
%* *
......@@ -48,18 +48,13 @@ import CLabel ( mkVecTblLabel, mkClosureTblLabel,
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn )
import Id ( Id, idPrimRep, isDeadBinder )
import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
isUnboxedTupleCon )
import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag )
import VarSet ( varSetElems )
import Literal ( Literal )
import PrimOp ( primOpOutOfLine, PrimOp(..) )
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
isFunTyCon, isPrimTyCon,
)
import Type ( Type, typePrimRep, splitAlgTyConApp,
splitTyConApp_maybe, repType )
import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
import Util
......@@ -148,8 +143,8 @@ CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
doesn't clash with anything else.
\begin{code}
cgCase (StgPrimApp op args res_ty)
live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
cgCase (StgPrimApp op args _)
live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
| isEnumerationTyCon tycon
= getArgAmodes args `thenFC` \ arg_amodes ->
......@@ -180,39 +175,44 @@ cgCase (StgPrimApp op args res_ty)
`thenC`
-- compile the alts
cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
False{-not poly case-} alts deflt
False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
where
(Just (tycon,_)) = splitTyConApp_maybe res_ty
uniq = getUnique bndr
\end{code}
Special case #2: inline PrimOps.
\begin{code}
cgCase (StgPrimApp op args res_ty)
live_in_whole_case live_in_alts bndr srt alts
cgCase (StgPrimApp op args _)
live_in_whole_case live_in_alts bndr srt alts
| not (primOpOutOfLine op)
=
-- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
let
result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
in
-- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
absC (COpStmt result_amodes op
arg_amodes -- note: no liveness arg
vol_regs) `thenC`
-- Scrutinise the result
cgInlineAlts bndr alts
case alts of
StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
-> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
op
arg_amodes -- note: no liveness arg
vol_regs) `thenC`
cgPrimInlineAlts bndr tycon alts deflt
StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
| isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
-> -- no heap check, no yield, just get in there and do it.
absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
op
arg_amodes -- note: no liveness arg
vol_regs) `thenC`
mapFCs bindNewToTemp args `thenFC` \ _ ->
cgExpr rhs
other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
\end{code}
TODO: Case-of-case of primop can probably be done inline too (but
......@@ -229,7 +229,7 @@ eliminate a heap check altogether.
\begin{code}
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
(StgPrimAlts ty alts deflt)
(StgPrimAlts tycon alts deflt)
=
getCAddrMode v `thenFC` \amode ->
......@@ -252,7 +252,8 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
live_in_whole_case live_in_alts bndr srt alts -- @(StgAlgAlts _ _ _)
-- SLPJ: Surely PrimAlts is ok too?
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
......@@ -265,24 +266,12 @@ cgCase (StgApp fun args)
allocStackTop retPrimRepSize `thenFC` \_ ->
forkEval alts_eob_info nopC (
deAllocStackTop retPrimRepSize `thenFC` \_ ->
cgEvalAlts maybe_cc_slot bndr srt alts)
deAllocStackTop retPrimRepSize `thenFC` \_ ->
cgEvalAlts maybe_cc_slot bndr srt alts)
`thenFC` \ scrut_eob_info ->
let real_scrut_eob_info =
if not_con_ty
then reserveSeqFrame scrut_eob_info
else scrut_eob_info
in
setEndOfBlockInfo real_scrut_eob_info (
tailCallFun fun fun_amode lf_info arg_amodes save_assts
)
where
not_con_ty = case (getScrutineeTyCon ty) of
Just _ -> False
other -> True
setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
tailCallFun fun fun_amode lf_info arg_amodes save_assts
\end{code}
Note about return addresses: we *always* push a return address, even
......@@ -311,26 +300,15 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alts
-- generate code for the alts
forkEval alts_eob_info
(
nukeDeadBindings live_in_alts `thenC`
(nukeDeadBindings live_in_alts `thenC`
allocStackTop retPrimRepSize -- space for retn address
`thenFC` \_ -> nopC
)
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
let real_scrut_eob_info =
if not_con_ty
then reserveSeqFrame scrut_eob_info
else scrut_eob_info
in
setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
where
not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
Just _ -> False
other -> True
setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
cgExpr expr
\end{code}
There's a lot of machinery going on behind the scenes to manage the
......@@ -368,52 +346,11 @@ don't follow the layout of closures when we're profiling. The CCS
could be anywhere within the record).
\begin{code}
alts_ty (StgAlgAlts ty _ _) = ty
alts_ty (StgPrimAlts ty _ _) = ty
\end{code}
%************************************************************************
%* *
\subsection[CgCase-primops]{Primitive applications}
%* *
%************************************************************************
Get result amodes for a primitive operation, in the case wher GC can't happen.
The amodes are returned in canonical order, ready for the prim-op!
Alg case: temporaries named as in the alternatives,
plus (CTemp u) for the tag (if needed)
Prim case: (CTemp u)
This is all disgusting, because these amodes must be consistent with those
invented by CgAlgAlts.
\begin{code}
getPrimAppResultAmodes
:: Unique
-> StgCaseAlts
-> [CAddrMode]
getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
| isUnboxedTupleTyCon tycon =
case alts of
[(con, args, use_mask, rhs)] ->
[ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
_ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
| otherwise = pprPanic "getPrimAppResultAmodes: case of primop has strange type:" (ppr ty)
where (tycon, _, _) = splitAlgTyConApp ty
-- The situation is simpler for primitive results, because there is only
-- one!
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
= [CTemp uniq (typePrimRep ty)]
-- We need to reserve a seq frame for a polymorphic case
maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
%************************************************************************
%* *
\subsection[CgCase-alts]{Alternatives}
......@@ -442,7 +379,7 @@ cgEvalAlts cc_slot bndr srt alts
case alts of
-- algebraic alts ...
(StgAlgAlts ty alts deflt) ->
StgAlgAlts maybe_tycon alts deflt ->
-- bind the default binder (it covers all the alternatives)
bindNewToReg bndr node mkLFArgument `thenC`
......@@ -456,9 +393,8 @@ cgEvalAlts cc_slot bndr srt alts
--
-- which is worse than having the alt code in the switch statement
let tycon_info = getScrutineeTyCon ty
is_alg = maybeToBool tycon_info
Just spec_tycon = tycon_info
let is_alg = maybeToBool maybe_tycon
Just spec_tycon = maybe_tycon
in
-- deal with the unboxed tuple case
......@@ -498,13 +434,13 @@ cgEvalAlts cc_slot bndr srt alts
returnFC (CaseAlts return_vec semi_tagged_stuff)
-- primitive alts...
(StgPrimAlts ty alts deflt) ->
StgPrimAlts tycon alts deflt ->
-- Restore the cost centre
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-- Generate the switch
getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
getSRTLabel `thenFC` \srt_label ->
......@@ -516,38 +452,12 @@ cgEvalAlts cc_slot bndr srt alts
\end{code}
\begin{code}
cgInlineAlts :: Id
-> StgCaseAlts
-> Code
\end{code}
HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
we do an inlining of the case no separate functions for returning are
created, so we don't have to generate a GRAN_YIELD in that case. This info
must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
emitted). Hence, the new Bool arg to cgAlgAltRhs.
First case: primitive op returns an unboxed tuple.
\begin{code}
cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
| isUnboxedTupleCon con
= -- no heap check, no yield, just get in there and do it.
mapFCs bindNewToTemp args `thenFC` \ _ ->
cgExpr rhs
| otherwise
= panic "cgInlineAlts: single alternative, not an unboxed tuple"
\end{code}
Third (real) case: primitive result type.
\begin{code}
cgInlineAlts bndr (StgPrimAlts ty alts deflt)
= cgPrimInlineAlts bndr ty alts deflt
\end{code}
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
......@@ -743,18 +653,19 @@ the maximum stack depth encountered down any branch.
As usual, no binders in the alternatives are yet bound.
\begin{code}
cgPrimInlineAlts bndr ty alts deflt
cgPrimInlineAlts bndr tycon alts deflt
= cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
where
uniq = getUnique bndr
kind = typePrimRep ty
kind = tyConPrimRep tycon
cgPrimEvalAlts bndr ty alts deflt
cgPrimEvalAlts bndr tycon alts deflt
= cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
where
reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
reg = WARN( case kind of { PtrRep -> True; other -> False },
text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
dataReturnConvPrim kind
kind = typePrimRep ty
kind = tyConPrimRep tycon
cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
= -- first bind the default if necessary
......@@ -982,15 +893,3 @@ possibleHeapCheck GCMayHappen is_alg regs tags lbl code
possibleHeapCheck NoGC _ _ tags lbl code
= code
\end{code}
\begin{code}
getScrutineeTyCon :: Type -> Maybe TyCon
getScrutineeTyCon ty =
case splitTyConApp_maybe (repType ty) of
Nothing -> Nothing
Just (tc,_) ->
if isFunTyCon tc then Nothing else -- not interested in funs
if isPrimTyCon tc then Just tc else -- return primitive tycons
-- otherwise (algebraic tycons) check the no. of constructors
Just tc
\end{code}
ghc/compiler/codeGen/CgExpr.lhs
View file @ 8b653a82
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.37 2000/11/07 13:12:22 simonpj Exp $
% $Id: CgExpr.lhs,v 1.38 2000/11/15 14:37:08 simonpj Exp $
%
%********************************************************
%* *
......@@ -315,7 +315,7 @@ mkRhsClosure bndr cc bi srt
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
(StgAlgAlts case_ty
(StgAlgAlts (Just tycon)
[(con, params, use_mask,
(StgApp selectee [{-no args-}]))]
StgNoDefault))
......@@ -332,7 +332,6 @@ mkRhsClosure bndr cc bi srt
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
tycon = dataConTyCon con
\end{code}
......
ghc/compiler/ghci/StgInterp.lhs
View file @ 8b653a82
......@@ -248,9 +248,9 @@ repOfStgExpr stgexpr
other
-> pprPanic "repOfStgExpr" (ppr other)
where
altRhss (StgAlgAlts ty alts def)
altRhss (StgAlgAlts tycon alts def)
= [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
altRhss (StgPrimAlts ty alts def)
altRhss (StgPrimAlts tycon alts def)
= [rhs | (lit,rhs) <- alts] ++ defRhs def
defRhs StgNoDefault
= []
......@@ -322,7 +322,7 @@ stg2expr ie stgexpr
(map doPrimAlt alts)
(def2expr def)
StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
| repOfStgExpr scrut == RepP
-> mkCaseAlg (repOfStgExpr stgexpr)
bndr (stg2expr ie scrut)
......
ghc/compiler/main/ErrUtils.lhs
View file @ 8b653a82
......@@ -5,7 +5,7 @@
\begin{code}
module ErrUtils (
ErrMsg, WarnMsg, Message, Messages, errorsFound,
ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine, dontAddErrLoc,
......@@ -67,6 +67,9 @@ type Messages = (Bag WarnMsg, Bag ErrMsg)
errorsFound :: Messages -> Bool
errorsFound (warns, errs) = not (isEmptyBag errs)
warningsFound :: Messages -> Bool
warningsFound (warns, errs) = not (isEmptyBag warns)
printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
-- Don't print any warnings if there are errors
printErrorsAndWarnings unqual (warns, errs)
......
ghc/compiler/main/HscMain.lhs
View file @ 8b653a82
......@@ -357,6 +357,34 @@ myCoreToStg dflags this_mod tidy_binds
\end{code}
%************************************************************************
%* *
\subsection{Compiling an expression}
%* *
%************************************************************************
hscExpr
:: DynFlags
-> HomeSymbolTable
-> HomeIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> Module -- Context for compiling
-> String -- The expression
-> IO HscResult
hscExpr dflags hst hit pcs this_module expr
= do { -- Parse it
; maybe_parsed <- myParseExpr dflags expr
; case maybe_parsed of {
Nothing -> return (HscFail pcs_ch);
Just parsed_expr -> do {
-- Rename it
(new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
case maybe_renamed_expr of {
Nothing ->
%************************************************************************
%* *
\subsection{Initial persistent state}
......
ghc/compiler/profiling/SCCfinal.lhs
View file @ 8b653a82
......@@ -192,19 +192,19 @@ stgMassageForProfiling mod_name us stg_binds
do_alts alts `thenMM` \ alts' ->
returnMM (StgCase expr' fv1 fv2 bndr srt alts')
where
do_alts (StgAlgAlts ty alts def)
do_alts (StgAlgAlts tycon alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
do_deflt def `thenMM` \ def' ->
returnMM (StgAlgAlts ty alts' def')
returnMM (StgAlgAlts tycon alts' def')
where
do_alt (id, bs, use_mask, e)
= do_expr e `thenMM` \ e' ->
returnMM (id, bs, use_mask, e')
do_alts (StgPrimAlts ty alts def)
do_alts (StgPrimAlts tycon alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
do_deflt def `thenMM` \ def' ->
returnMM (StgPrimAlts ty alts' def')
returnMM (StgPrimAlts tycon alts' def')
where
do_alt (l,e)
= do_expr e `thenMM` \ e' ->
......
ghc/compiler/rename/Rename.lhs
View file @ 8b653a82
......@@ -4,21 +4,22 @@
\section[Rename]{Renaming and dependency analysis passes}
\begin{code}
module Rename ( renameModule, closeIfaceDecls, checkOldIface ) where
module Rename ( renameModule, renameExpr, closeIfaceDecls, checkOldIface ) where
#include "HsVersions.h"
import HsSyn
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameHsExpr,
RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
extractHsTyNames,
extractHsTyNames, RenamedHsExpr,
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
import RnExpr ( rnExpr )
import RnNames ( getGlobalNames, exportsFromAvail )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo,
......@@ -34,7 +35,7 @@ import RnEnv ( availsToNameSet, availName,
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
moduleEnvElts
moduleEnvElts, lookupModuleEnv
)
import Name ( Name, NamedThing(..), getSrcLoc,
nameIsLocalOrFrom, nameOccName, nameModule,
......@@ -74,9 +75,10 @@ import List ( partition, nub )
%*********************************************************
%* *
\subsection{The main function: rename}
\subsection{The two main wrappers}
%* *
%*********************************************************
......@@ -88,20 +90,63 @@ renameModule :: DynFlags
-> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
-- Nothing => some error occurred in the renamer
renameModule dflags hit hst old_pcs this_module rdr_module
= do { showPass dflags "Renamer"
renameModule dflags hit hst pcs this_module rdr_module
= renameSource dflags hit hst pcs this_module get_unqual $
rename this_module rdr_module
where
get_unqual (Just (unqual, _, _, _)) = unqual
get_unqual Nothing = alwaysQualify
\end{code}
-- Initialise the renamer monad
; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module
(rename this_module rdr_module)
; let print_unqualified = case maybe_rn_stuff of
Just (unqual, _, _, _) -> unqual
Nothing -> alwaysQualify
\begin{code}
renameExpr :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsExpr
-> IO (PersistentCompilerState, Maybe RenamedHsExpr)
renameExpr dflags hit hst pcs this_module expr
| Just iface <- lookupModuleEnv hit this_module
= do { let rdr_env = mi_globals iface
; let get_unqual _ = unQualInScope rdr_env
; renameSource dflags hit hst pcs this_module get_unqual $
initRnMS rdr_env emptyLocalFixityEnv SourceMode $
(rnExpr expr `thenRn` \ (e,_) -> returnRn (Just e))
}
| otherwise
= do { printErrs alwaysQualify (ptext SLIT("renameExpr: Bad module context") <+> ppr this_module)
; return (pcs, Nothing)
}
\end{code}
%*********************************************************
%* *
\subsection{The main function: rename}
%* *
%*********************************************************
\begin{code}
renameSource :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module
-> (Maybe r -> PrintUnqualified)
-> RnMG (Maybe r)
-> IO (PersistentCompilerState, Maybe r)
-- Nothing => some error occurred in the renamer
renameSource dflags hit hst old_pcs this_module get_unqual thing_inside
= do { showPass dflags "Renamer"
-- Initialise the renamer monad
; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside
-- Print errors from renaming
; printErrorsAndWarnings print_unqualified msgs ;
; printErrorsAndWarnings (get_unqual maybe_rn_stuff) msgs ;
-- Return results. No harm in updating the PCS
; if errorsFound msgs then
......
ghc/compiler/rename/RnMonad.lhs
View file @ 8b653a82
......@@ -31,6 +31,7 @@ import PrelIOBase ( fixIO ) -- Should be in GlaExts
import IOBase ( fixIO )
#endif
import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )
import IO ( hPutStr, stderr )
import HsSyn
import RdrHsSyn
......@@ -46,7 +47,7 @@ import HscTypes ( AvailEnv, lookupType,
RdrAvailInfo )
import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, Message, Messages, errorsFound,
Message, Messages, errorsFound, warningsFound,
printErrorsAndWarnings
)
import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
......@@ -183,6 +184,9 @@ type LocalFixityEnv = NameEnv RenamedFixitySig
-- can report line-number info when there is a duplicate
-- fixity declaration
emptyLocalFixityEnv :: LocalFixityEnv
emptyLocalFixityEnv = emptyNameEnv
lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
lookupLocalFixity env name
= case lookupNameEnv env name of
......@@ -365,6 +369,9 @@ initRn dflags hit hst pcs mod do_rn
return (new_pcs, (warns, errs), res)
initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode
-> RnMS a -> RnM d a
initRnMS rn_env fixity_env mode thing_inside rn_down g_down
-- The fixity_env appears in both the rn_fixenv field
-- and in the HIT. See comments with RnHiFiles.lookupFixityRn
......@@ -376,11 +383,11 @@ initRnMS rn_env fixity_env mode thing_inside rn_down g_down
initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
= initRnMS emptyRdrEnv emptyLocalFixityEnv InterfaceMode $
setModuleRn mod thing_inside
\end{code}
@renameSourceCode@ is used to rename stuff ``out-of-line'';
@renameDerivedCode@ is used to rename stuff ``out-of-line'';
that is, not as part of the main renamer.
Sole examples: derived definitions,
which are only generated in the type checker.
......@@ -389,52 +396,54 @@ The @NameSupply@ includes a @UniqueSupply@, so if you call it more than
once you must either split it, or install a fresh unique supply.
\begin{code}
renameSourceCode :: DynFlags
-> Module
-> PersistentRenamerState
-> RnMS r
-> r
renameSourceCode dflags mod prs m
= unsafePerformIO (
renameDerivedCode :: DynFlags
-> Module
-> PersistentRenamerState
-> RnMS r
-> r
renameDerivedCode dflags mod prs thing_inside
= unsafePerformIO $
-- It's not really unsafe! When renaming source code we
-- only do any I/O if we need to read in a fixity declaration;
-- and that doesn't happen in pragmas etc
mkSplitUniqSupply 'r' >>= \ new_us ->
newIORef (new_us, origNames (prsOrig prs),
origIParam (prsOrig prs)) >>= \ names_var ->
newIORef (emptyBag,emptyBag) >>= \ errs_var ->
let
rn_down = RnDown { rn_dflags = dflags,
rn_loc = generatedSrcLoc, rn_ns = names_var,
rn_errs = errs_var,
rn_mod = mod,
rn_done = bogus "rn_done", rn_hit = bogus "rn_hit",