Commit 68afb167 authored by partain's avatar partain
Browse files

[project @ 1996-05-06 11:01:29 by partain]

SLPJ 1.3 changes through 960505
parent 3990d444
...@@ -39,7 +39,10 @@ module CLabel ( ...@@ -39,7 +39,10 @@ module CLabel (
needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
pprCLabel, pprCLabel_asm pprCLabel
#if ! OMIT_NATIVE_CODEGEN
, pprCLabel_asm
#endif
#ifdef GRAN #ifdef GRAN
, isSlowEntryCCodeBlock , isSlowEntryCCodeBlock
...@@ -50,7 +53,9 @@ import Ubiq{-uitous-} ...@@ -50,7 +53,9 @@ import Ubiq{-uitous-}
import AbsCLoop ( CtrlReturnConvention(..), import AbsCLoop ( CtrlReturnConvention(..),
ctrlReturnConvAlg ctrlReturnConvAlg
) )
#if ! OMIT_NATIVE_CODEGEN
import NcgLoop ( underscorePrefix, fmtAsmLbl ) import NcgLoop ( underscorePrefix, fmtAsmLbl )
#endif
import CStrings ( pp_cSEP ) import CStrings ( pp_cSEP )
import Id ( externallyVisibleId, cmpId_withSpecDataCon, import Id ( externallyVisibleId, cmpId_withSpecDataCon,
...@@ -314,7 +319,9 @@ duplicate declarations in generating C (see @labelSeenTE@ in ...@@ -314,7 +319,9 @@ duplicate declarations in generating C (see @labelSeenTE@ in
\begin{code} \begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG -- specialised for PprAsm: saves lots of arg passing in NCG
#if ! OMIT_NATIVE_CODEGEN
pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
#endif
pprCLabel :: PprStyle -> CLabel -> Unpretty pprCLabel :: PprStyle -> CLabel -> Unpretty
......
...@@ -45,7 +45,9 @@ import Id ( idPrimRep, toplevelishId, isDataCon, ...@@ -45,7 +45,9 @@ import Id ( idPrimRep, toplevelishId, isDataCon,
) )
import Maybes ( catMaybes ) import Maybes ( catMaybes )
import Name ( isLocallyDefined ) import Name ( isLocallyDefined )
#ifdef DEBUG
import PprAbsC ( pprAmode ) import PprAbsC ( pprAmode )
#endif
import PprStyle ( PprStyle(..) ) import PprStyle ( PprStyle(..) )
import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
import Unpretty ( uppShow ) import Unpretty ( uppShow )
......
...@@ -259,9 +259,9 @@ mkCoLetNoUnboxed bind@(NonRec binder rhs) body ...@@ -259,9 +259,9 @@ mkCoLetNoUnboxed bind@(NonRec binder rhs) body
mkCoLetsNoUnboxed [] expr = expr mkCoLetsNoUnboxed [] expr = expr
mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
--mkCoLetrecNoUnboxed :: [(Id, CoreExpr)] -- bindings mkCoLetrecNoUnboxed :: [(GenId (GenType a b), GenCoreExpr (GenId (GenType a b)) c d e)]
-- -> CoreExpr -- body -> GenCoreExpr (GenId (GenType a b)) c d e
-- -> CoreExpr -- result -> GenCoreExpr (GenId (GenType a b)) c d e
mkCoLetrecNoUnboxed [] body = body mkCoLetrecNoUnboxed [] body = body
mkCoLetrecNoUnboxed binds body mkCoLetrecNoUnboxed binds body
......
...@@ -16,9 +16,12 @@ import Ubiq ...@@ -16,9 +16,12 @@ import Ubiq
import DsLoop -- break dsExpr-ish loop import DsLoop -- break dsExpr-ish loop
import HsSyn -- lots of things import HsSyn -- lots of things
hiding ( collectBinders{-also in CoreSyn-} )
import CoreSyn -- lots of things import CoreSyn -- lots of things
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
TypecheckedBind(..), TypecheckedMonoBinds(..) ) TypecheckedBind(..), TypecheckedMonoBinds(..),
TypecheckedPat(..)
)
import DsHsSyn ( collectTypedBinders, collectTypedPatBinders ) import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
import DsMonad import DsMonad
...@@ -39,7 +42,7 @@ import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy, ...@@ -39,7 +42,7 @@ import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} ) import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic, pprTrace{-ToDo:rm-} ) import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
import PprCore--ToDo:rm import PprCore--ToDo:rm
import PprType--ToDo:rm import PprType ( GenTyVar ) --ToDo:rm
import Usage--ToDo:rm import Usage--ToDo:rm
import Unique--ToDo:rm import Unique--ToDo:rm
......
...@@ -14,7 +14,7 @@ import DsLoop -- partly to get dsBinds, partly to chk dsExpr ...@@ -14,7 +14,7 @@ import DsLoop -- partly to get dsBinds, partly to chk dsExpr
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
Match, Qual, HsBinds, Stmt, PolyType ) Match, Qual, HsBinds, Stmt, PolyType )
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
TypecheckedRecordBinds(..) TypecheckedRecordBinds(..), TypecheckedPat(..)
) )
import CoreSyn import CoreSyn
...@@ -22,7 +22,8 @@ import DsMonad ...@@ -22,7 +22,8 @@ import DsMonad
import DsCCall ( dsCCall ) import DsCCall ( dsCCall )
import DsListComp ( dsListComp ) import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr mkErrorAppDs, showForErr, EquationInfo,
MatchResult
) )
import Match ( matchWrapper ) import Match ( matchWrapper )
...@@ -38,6 +39,7 @@ import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv, ...@@ -38,6 +39,7 @@ import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
) )
import Literal ( mkMachInt, Literal(..) ) import Literal ( mkMachInt, Literal(..) )
import MagicUFs ( MagicUnfoldingFun ) import MagicUFs ( MagicUnfoldingFun )
import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) ) import PprStyle ( PprStyle(..) )
import PprType ( GenType ) import PprType ( GenType )
import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon, import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
......
...@@ -10,7 +10,7 @@ import Ubiq ...@@ -10,7 +10,7 @@ import Ubiq
import DsLoop -- break dsExpr-ish loop import DsLoop -- break dsExpr-ish loop
import HsSyn ( Qual(..), HsExpr, HsBinds ) import HsSyn ( Qual(..), HsExpr, HsBinds )
import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) ) import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
import DsHsSyn ( outPatType ) import DsHsSyn ( outPatType )
import CoreSyn import CoreSyn
......
...@@ -12,7 +12,7 @@ import Ubiq ...@@ -12,7 +12,7 @@ import Ubiq
import DsLoop -- here for paranoia-checking reasons import DsLoop -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop -- and to break dsExpr/dsBinds-ish loop
import HsSyn import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..), import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..),
TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
import DsHsSyn ( outPatType, collectTypedPatBinders ) import DsHsSyn ( outPatType, collectTypedPatBinders )
......
...@@ -13,8 +13,10 @@ import DsLoop -- break match-ish and dsExpr-ish loops ...@@ -13,8 +13,10 @@ import DsLoop -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
import TcHsSyn ( TypecheckedHsExpr(..) ) import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
import CoreSyn ( CoreExpr(..) ) TypecheckedPat(..)
)
import CoreSyn ( CoreExpr(..), CoreBinding(..) )
import DsMonad import DsMonad
import DsUtils import DsUtils
......
...@@ -24,6 +24,7 @@ import Bag ( emptyBag, snocBag, bagToList ) ...@@ -24,6 +24,7 @@ import Bag ( emptyBag, snocBag, bagToList )
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import CmdLineOpts ( opt_ProduceHi ) import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} ) import FieldLabel ( FieldLabel{-instance NamedThing-} )
import FiniteMap ( fmToList )
import HsSyn import HsSyn
import Id ( idType, dataConSig, dataConFieldLabels, import Id ( idType, dataConSig, dataConFieldLabels,
dataConStrictMarks, StrictnessMark(..), dataConStrictMarks, StrictnessMark(..),
...@@ -128,15 +129,34 @@ endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl ...@@ -128,15 +129,34 @@ endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
\begin{code} \begin{code}
ifaceUsages Nothing{-no iface handle-} _ = return () ifaceUsages Nothing{-no iface handle-} _ = return ()
ifaceUsages (Just if_hdl) version_info ifaceUsages (Just if_hdl) usages
= hPutStr if_hdl "__usages__\nFoo 1" -- a stub, obviously | null usages_list
= return ()
| otherwise
= hPutStr if_hdl "__usages__\n" >>
hPutStr if_hdl (ppShow 10000 (ppAboves (map pp_uses usages_list)))
where
usages_list = fmToList usages
pp_uses (m, (mv, versions))
= ppBesides [ppPStr m, ppSP, ppInt mv, ppPStr SLIT(" :: "),
pp_versions (fmToList versions), ppSemi]
\end{code} \end{code}
\begin{code} \begin{code}
ifaceVersions Nothing{-no iface handle-} _ = return () ifaceVersions Nothing{-no iface handle-} _ = return ()
ifaceVersions (Just if_hdl) version_info ifaceVersions (Just if_hdl) version_info
= hPutStr if_hdl "\n__versions__\nFoo 1" -- a stub, obviously | null version_list
= return ()
| otherwise
= hPutStr if_hdl "\n__versions__\n" >>
hPutStr if_hdl (ppShow 10000 (pp_versions version_list))
where
version_list = fmToList version_info
pp_versions nvs
= ppInterleave ppComma [ ppCat [ppPStr n, ppInt v] | (n,v) <- nvs ]
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -28,7 +28,7 @@ import RdrHsSyn ...@@ -28,7 +28,7 @@ import RdrHsSyn
import HsPragmas ( noGenPragmas, noClassOpPragmas ) import HsPragmas ( noGenPragmas, noClassOpPragmas )
import SrcLoc ( mkSrcLoc2 ) import SrcLoc ( mkSrcLoc2 )
import Util ( panic, assertPanic ) import Util ( mapAndUnzip, panic, assertPanic )
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -154,7 +154,7 @@ cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn ...@@ -154,7 +154,7 @@ cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn
cvFunMonoBind sf matches cvFunMonoBind sf matches
= (head srcfuns, head infixdefs, cvMatches sf False matches) = (head srcfuns, head infixdefs, cvMatches sf False matches)
where where
(srcfuns, infixdefs) = unzip (map get_mdef matches) (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
-- ToDo: Check for consistent srcfun and infixdef -- ToDo: Check for consistent srcfun and infixdef
get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
......
...@@ -228,7 +228,8 @@ mk_inst ctxt clas mono_ty ...@@ -228,7 +228,8 @@ mk_inst ctxt clas mono_ty
lexIface :: String -> [IfaceToken] lexIface :: String -> [IfaceToken]
lexIface str lexIface str
= case str of = _scc_ "Lexer"
case str of
[] -> [] [] -> []
-- whitespace and comments -- whitespace and comments
......
...@@ -81,7 +81,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) ...@@ -81,7 +81,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
-- ]}) $ -- ]}) $
findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files -> findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files ->
newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
let let
...@@ -196,7 +196,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) ...@@ -196,7 +196,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
\begin{code} \begin{code}
{- TESTING: {- TESTING:
pprPIface (ParsedIface m v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
= ppAboves [ = ppAboves [
ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v, ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
case mv of { Nothing -> ppNil; Just n -> ppInt n }], case mv of { Nothing -> ppNil; Just n -> ppInt n }],
......
...@@ -28,10 +28,11 @@ import RnMonad ...@@ -28,10 +28,11 @@ import RnMonad
import ErrUtils ( addErrLoc, addShortErrLocLine ) import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( isLocallyDefinedName, pprSym, Name, RdrName ) import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
import Pretty import Pretty
import UniqFM ( lookupUFM ) import UniqFM ( lookupUFM, ufmToList{-ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet, import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets, unionUniqSets, unionManyUniqSets,
UniqSet(..) ) UniqSet(..)
)
import Util ( Ord3(..), removeDups, panic ) import Util ( Ord3(..), removeDups, panic )
\end{code} \end{code}
...@@ -485,6 +486,7 @@ precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2) ...@@ -485,6 +486,7 @@ precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2) precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
= lookupFixity op `thenRn` \ (op_fix, op_prec) -> = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
-- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
case cmp op1_prec op_prec of case cmp op1_prec op_prec of
LT_ -> rearrange LT_ -> rearrange
EQ_ -> case (op1_fix, op_fix) of EQ_ -> case (op1_fix, op_fix) of
...@@ -534,6 +536,7 @@ data INFIX = INFIXL | INFIXR | INFIXN deriving Eq ...@@ -534,6 +536,7 @@ data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int) lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
lookupFixity op lookupFixity op
= getExtraRn `thenRn` \ fixity_fm -> = getExtraRn `thenRn` \ fixity_fm ->
-- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $
case lookupUFM fixity_fm op of case lookupUFM fixity_fm op of
Nothing -> returnRn (INFIXL, 9) Nothing -> returnRn (INFIXL, 9)
Just (InfixL _ n) -> returnRn (INFIXL, n) Just (InfixL _ n) -> returnRn (INFIXL, n)
......
...@@ -37,8 +37,9 @@ import Bag ( emptyBag, unitBag, consBag, snocBag, ...@@ -37,8 +37,9 @@ import Bag ( emptyBag, unitBag, consBag, snocBag,
unionBags, unionManyBags, isEmptyBag, bagToList ) unionBags, unionManyBags, isEmptyBag, bagToList )
import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
import ErrUtils ( Error(..), Warning(..) ) import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, plusFM_C, eltsFM, import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} fmToList, delListFromFM, sizeFM, foldFM, unitFM,
plusFM_C, keysFM{-ToDo:rm-}
) )
import Maybes ( maybeToBool ) import Maybes ( maybeToBool )
import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) ) import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) )
...@@ -77,9 +78,9 @@ absolute-filename-for-that-interface. ...@@ -77,9 +78,9 @@ absolute-filename-for-that-interface.
findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath) findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
findHiFiles dirs sysdirs findHiFiles dirs sysdirs
= hPutStr stderr " findHiFiles " >> = --hPutStr stderr " findHiFiles " >>
do_dirs emptyFM (dirs ++ sysdirs) >>= \ result -> do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
hPutStr stderr " done\n" >> --hPutStr stderr " done\n" >>
return result return result
where where
do_dirs env [] = return env do_dirs env [] = return env
...@@ -88,7 +89,7 @@ findHiFiles dirs sysdirs ...@@ -88,7 +89,7 @@ findHiFiles dirs sysdirs
do_dirs new_env dirs do_dirs new_env dirs
------- -------
do_dir env dir do_dir env dir
= hPutStr stderr "D" >> = --hPutStr stderr "D" >>
getDirectoryContents dir >>= \ entries -> getDirectoryContents dir >>= \ entries ->
do_entries env entries do_entries env entries
where where
...@@ -100,7 +101,7 @@ findHiFiles dirs sysdirs ...@@ -100,7 +101,7 @@ findHiFiles dirs sysdirs
do_entry env e do_entry env e
= case (acceptable_hi (reverse e)) of = case (acceptable_hi (reverse e)) of
Nothing -> --trace ("Deemed uncool:"++e) $ Nothing -> --trace ("Deemed uncool:"++e) $
hPutStr stderr "." >> --hPutStr stderr "." >>
return env return env
Just mod -> Just mod ->
let let
...@@ -108,12 +109,12 @@ findHiFiles dirs sysdirs ...@@ -108,12 +109,12 @@ findHiFiles dirs sysdirs
in in
case (lookupFM env pmod) of case (lookupFM env pmod) of
Nothing -> --trace ("Adding "++mod++" -> "++e) $ Nothing -> --trace ("Adding "++mod++" -> "++e) $
hPutStr stderr "!" >> --hPutStr stderr "!" >>
return (addToFM env pmod (dir ++ '/':e)) return (addToFM env pmod (dir ++ '/':e))
-- ToDo: use DIR_SEP, not / -- ToDo: use DIR_SEP, not /
Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $ Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
hPutStr stderr "." >> --hPutStr stderr "." >>
return env return env
------- -------
acceptable_hi rev_e -- looking at pathname *backwards* acceptable_hi rev_e -- looking at pathname *backwards*
...@@ -194,7 +195,7 @@ cachedIface want_orig_iface iface_cache mod ...@@ -194,7 +195,7 @@ cachedIface want_orig_iface iface_cache mod
where where
want_iface iface orig_fm want_iface iface orig_fm
| want_orig_iface | want_orig_iface
= case lookupFM orig_fm of = case lookupFM orig_fm mod of
Nothing -> Failed (noOrigIfaceErr mod) Nothing -> Failed (noOrigIfaceErr mod)
Just orig_iface -> Succeeded orig_iface Just orig_iface -> Succeeded orig_iface
| otherwise | otherwise
...@@ -224,7 +225,7 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs ...@@ -224,7 +225,7 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs
where where
dup_merge str ppr_dup dup1 dup2 dup_merge str ppr_dup dup1 dup2
= pprTrace "mergeIfaces:" = pprTrace "mergeIfaces:"
(ppCat [ppPStr mod, ppPStr mod1, ppStr ": dup", ppStr str, ppStr "decl", (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
ppr_dup dup1, ppr_dup dup2]) $ ppr_dup dup1, ppr_dup dup2]) $
dup2 dup2
...@@ -312,14 +313,18 @@ readIface :: FilePath -> Module ...@@ -312,14 +313,18 @@ readIface :: FilePath -> Module
-> IO (MaybeErr ParsedIface Error) -> IO (MaybeErr ParsedIface Error)
readIface file mod readIface file mod
= hPutStr stderr (" reading "++file) >> = --hPutStr stderr (" reading "++file) >>
readFile file `thenPrimIO` \ read_result -> readFile file `thenPrimIO` \ read_result ->
case read_result of case read_result of
Left err -> return (Failed (cannaeReadErr file err)) Left err -> return (Failed (cannaeReadErr file err))
Right contents -> hPutStr stderr " parsing" >> Right contents -> --hPutStr stderr " parsing" >>
let parsed = parseIface contents in let parsed = parseIface contents in
hPutStr stderr " done\n" >> --hPutStr stderr " done\n" >>
return (Succeeded (init_merge mod parsed)) return (
case parsed of
Failed _ -> parsed
Succeeded p -> Succeeded (init_merge mod p)
)
where where
init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags) init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
= ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
...@@ -374,7 +379,7 @@ rnIfaces iface_cache imp_mods us ...@@ -374,7 +379,7 @@ rnIfaces iface_cache imp_mods us
-- finalize what we want to say we learned about the -- finalize what we want to say we learned about the
-- things we used -- things we used
finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>= finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
\ usage_stuff@(usage_info, version_info, instance_mods) -> \ usage_stuff@(usage_info, version_info, instance_mods) ->
return (HsModule modname iface_version exports imports fixities return (HsModule modname iface_version exports imports fixities
...@@ -779,6 +784,7 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl ...@@ -779,6 +784,7 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
\begin{code} \begin{code}
finalIfaceInfo :: finalIfaceInfo ::
IfaceCache -- iface cache IfaceCache -- iface cache
-> Module -- this module's name
-> RnEnv -> RnEnv
-> [RenamedInstDecl] -> [RenamedInstDecl]
-- -> [RnName] -- all imported names required -- -> [RnName] -- all imported names required
...@@ -787,14 +793,47 @@ finalIfaceInfo :: ...@@ -787,14 +793,47 @@ finalIfaceInfo ::
VersionsMap, -- info about version numbers VersionsMap, -- info about version numbers
[Module]) -- special instance modules [Module]) -- special instance modules
finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls finalIfaceInfo iface_cache modname 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:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ -- 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_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
let
val_stuff@(val_usages, val_versions)
= foldFM process_item (emptyFM, emptyFM){-init-} qual
return (emptyFM, emptyFM, []) (all_usages, all_versions)
= foldFM process_item val_stuff{-keep going-} tc_qual
in
return (all_usages, all_versions, [])
where
process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
-> (UsagesMap, VersionsMap) -- input
-> (UsagesMap, VersionsMap) -- output
process_item (n,m) rn as_before@(usages, versions)
| irrelevant rn
= as_before
| m == modname -- this module => add to "versions"
= (usages, addToFM versions n 1{-stub-})
| otherwise -- from another module => add to "usages"
= (add_to_usages usages m n 1{-stub-}, versions)
irrelevant (RnConstr _ _) = True -- We don't report these in their
irrelevant (RnField _ _) = True -- own right in usages/etc.
irrelevant (RnClassOp _ _) = True
irrelevant _ = False
add_to_usages usages m n version
= addToFM usages m (
case (lookupFM usages m) of
Nothing -> -- nothing for this module yet...
(1{-stub-}, unitFM n version)
Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
(mversion, addToFM mstuff n version)
)
\end{code} \end{code}
......
...@@ -289,7 +289,7 @@ newGlobalName locn maybe_exp rdr ...@@ -289,7 +289,7 @@ newGlobalName locn maybe_exp rdr
Just exp -> exp Just exp -> exp
Nothing -> exp_fn n Nothing -> exp_fn n
n = mkTopLevName uniq orig locn exp (occ_fn n) n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s
in in
addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_` addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_`
addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
...@@ -363,6 +363,9 @@ doImportDecls iface_cache g_info us src_imps ...@@ -363,6 +363,9 @@ doImportDecls iface_cache g_info us src_imps
then [{- no "import Prelude" -}] then [{- no "import Prelude" -}]
else [ImportDecl pRELUDE False Nothing Nothing prel_loc] else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_imps -- WDP: Just guessing on this defn... ToDo
= [ imp | imp@(ImportDecl mod _ _ _ _) <- the_imps, fromPrelude mod ]
prel_loc = mkBuiltinSrcLoc prel_loc = mkBuiltinSrcLoc
(uniq_imps, imp_dups) = removeDups cmp_mod the_imps (uniq_imps, imp_dups) = removeDups cmp_mod the_imps
...@@ -431,15 +434,16 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) ...@@ -431,15 +434,16 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
accumulate (map (checkOrigIE iface_cache) chk_ies) accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->