Commit 99073d87 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-24 08:40:09 by simonpj]

Small wibbles
parent 323fee1e
......@@ -56,6 +56,7 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet,
import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
import GlaExts
import Util ( nOfThem )
import ST
......@@ -1266,9 +1267,9 @@ pprMagicId BaseReg = ptext SLIT("BaseReg")
pprMagicId (VanillaReg pk n)
= hcat [ pprVanillaReg n, char '.',
pprUnionTag pk ]
pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n))
pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n))
pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n))
pprMagicId (FloatReg n) = ptext SLIT("F") <> int (I# n)
pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n)
pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n)
pprMagicId Sp = ptext SLIT("Sp")
pprMagicId Su = ptext SLIT("Su")
pprMagicId SpLim = ptext SLIT("SpLim")
......@@ -1277,8 +1278,8 @@ pprMagicId HpLim = ptext SLIT("HpLim")
pprMagicId CurCostCentre = ptext SLIT("CCCS")
pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
pprVanillaReg :: FastInt -> SDoc
pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
pprVanillaReg :: Int# -> SDoc
pprVanillaReg n = char 'R' <> int (I# n)
pprUnionTag :: PrimRep -> SDoc
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgClosure.lhs,v 1.41 2000/07/14 08:14:53 simonpj Exp $
% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
......@@ -57,7 +57,8 @@ import Outputable
import Name ( nameOccName )
import OccName ( occNameFS )
import FastTypes ( iBox )
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
......@@ -539,7 +540,7 @@ argSatisfactionCheck closure_info arg_regs
getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
off = I# sp
off = iBox sp
rel_arg = mkIntCLit off
in
ASSERT(off /= 0)
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgHeapery.lhs,v 1.23 2000/07/26 14:48:16 simonmar Exp $
% $Id: CgHeapery.lhs,v 1.24 2000/10/24 08:40:10 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
......@@ -197,7 +197,7 @@ fastEntryChecks regs tags ret node_points code
tag_assts
free_reg = case length regs + 1 of
IBOX(x) -> CReg (VanillaReg PtrRep x)
I# x -> CReg (VanillaReg PtrRep x)
all_pointers = all pointer regs
pointer (VanillaReg rep _) = isFollowableRep rep
......@@ -283,19 +283,19 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
tag_assts
-}
-- this will cover all cases for x86
[VanillaReg rep ILIT(1)]
[VanillaReg rep 1#]
| isFollowableRep rep ->
CCheck HP_CHK_UT_ALT
[mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
CReg (VanillaReg RetRep ILIT(2)),
CReg (VanillaReg RetRep 2#),
CLbl (mkReturnInfoLabel ret_addr) RetRep]
tag_assts
| otherwise ->
CCheck HP_CHK_UT_ALT
[mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
CReg (VanillaReg RetRep ILIT(2)),
CReg (VanillaReg RetRep 2#),
CLbl (mkReturnInfoLabel ret_addr) RetRep]
tag_assts
......@@ -304,7 +304,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
in
CCheck HP_CHK_GEN
[mkIntCLit words_required,
mkIntCLit (IBOX(word2Int# liveness)),
mkIntCLit (I# (word2Int# liveness)),
-- HP_CHK_GEN needs a direct return address,
-- not an info table (might be different if
-- we're not assembly-mangling/tail-jumping etc.)
......@@ -346,7 +346,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
-- We need this case because the closure in Node won't return
-- directly when we enter it (it could be a function), so the
-- heap check code needs to push a seq frame on top of the stack.
[VanillaReg rep ILIT(1)]
[VanillaReg rep 1#]
| rep == PtrRep
&& is_fun ->
CCheck HP_CHK_SEQ_NP
......@@ -354,7 +354,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
AbsCNop
-- R1 is lifted (the common case)
[VanillaReg rep ILIT(1)]
[VanillaReg rep 1#]
| rep == PtrRep ->
CCheck HP_CHK_NP
[mkIntCLit words_required, mkIntCLit 1{-regs live-}]
......@@ -369,15 +369,15 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
-- FloatReg1
[FloatReg ILIT(1)] ->
[FloatReg 1#] ->
CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-- DblReg1
[DoubleReg ILIT(1)] ->
[DoubleReg 1#] ->
CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-- LngReg1
[LongReg _ ILIT(1)] ->
[LongReg _ 1#] ->
CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
#ifdef DEBUG
......@@ -406,7 +406,7 @@ fetchAndReschedule regs node_reqd =
where
liveness_mask = mkRegLiveness regs
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit (IBOX(word2Int# liveness_mask)),
mkIntCLit (I# (word2Int# liveness_mask)),
mkIntCLit (if node_reqd then 1 else 0)])
--HWL: generate GRAN_FETCH macro for GrAnSim
......@@ -440,7 +440,7 @@ yield regs node_reqd =
liveness_mask = mkRegLiveness regs
yield_code =
absC (CMacroStmt GRAN_YIELD
[mkIntCLit (IBOX(word2Int# liveness_mask))])
[mkIntCLit (I# (word2Int# liveness_mask))])
\end{code}
\begin{code}
......
......@@ -11,7 +11,7 @@ module CoreTidy (
#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn )
import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
......@@ -34,7 +34,7 @@ import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
import OccName ( initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
import Module ( Module )
import UniqSupply ( UniqSupply )
import UniqSupply ( mkSplitUniqSupply )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Util ( mapAccumL )
......@@ -66,22 +66,27 @@ Several tasks are done by @tidyCorePgm@
from the uniques for local thunks etc.]
\begin{code}
tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> RuleBase
tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
-> IO ([CoreBind], [ProtoCoreRule])
tidyCorePgm us module_name binds_in rulebase_in
tidyCorePgm dflags module_name binds_in rulebase_in
= do
beginPass "Tidy Core"
us <- mkSplitUniqSupply 'u'
beginPass dflags "Tidy Core"
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
doUsageSPInf us binds_in rulebase_in
doUsageSPInf dflags us binds_in rulebase_in
else return binds_in
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
init_tidy_env binds_in1
rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in)
endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
dopt Opt_D_verbose_core2core dflags)
binds_out
return (binds_out, rules_out)
where
-- We also make sure to avoid any exported binders. Consider
......
......@@ -32,18 +32,13 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
import Type ( unUsgTy, repType,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
)
import PrimOp ( PrimOp(..), CCall(..),
CCallTarget(..), dynamicTarget )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
addrDataCon
mkFunTy, splitAppTy, applyTy, funResultTy
)
import PrimOp ( CCall(..), CCallTarget(..), dynamicTarget )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
import PrelNames ( Uniquable(..), hasKey,
ioTyConKey, deRefStablePtrName, returnIOIdKey,
bindIOName,
returnIOName, makeStablePtrName
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName,
bindIOName, returnIOName, makeStablePtrName
)
import Outputable
......
......@@ -37,7 +37,6 @@ import Type ( Type )
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
import UniqFM ( lookupWithDefaultUFM_Directly )
import Util ( zipWithEqual )
import Name ( Name, lookupNameEnv )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..),
......
......@@ -8,7 +8,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
import DsHsSyn ( outPatType )
......
......@@ -111,7 +111,6 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface
mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
mkSplitUniqSupply 'u' >>= \ tidy_uniqs -> -- tidy up
mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
......@@ -158,7 +157,7 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface
core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
-- Do the final tidy-up
tidyCorePgm tidy_uniqs this_mod
tidyCorePgm this_mod
simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
-- Run the occurrence analyser one last time, so that
......
......@@ -9,7 +9,8 @@ module HscTypes (
ModDetails(..), ModIface(..), GlobalSymbolTable,
HomeSymbolTable, PackageSymbolTable,
HomeIfaceTable, PackageIfaceTable,
HomeIfaceTable, PackageIfaceTable,
lookupTable,
IfaceDecls(..),
......@@ -19,8 +20,6 @@ module HscTypes (
TypeEnv, extendTypeEnv, lookupTypeEnv,
lookupFixityEnv,
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl,
......@@ -68,6 +67,7 @@ import Type ( Type )
import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
import Bag ( Bag )
import Maybes ( seqMaybe )
import UniqFM ( UniqFM )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
......@@ -118,7 +118,10 @@ data ModIface
mi_version :: VersionInfo, -- Module version number
mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
mi_usages :: [ImportVersion Name], -- Usages; kept sorted
mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy
-- to decide whether to write a new iface file
-- (changing usages doesn't affect the version of
-- this module)
mi_exports :: Avails, -- What it exports
-- Kept sorted by (mod,occ),
......@@ -182,11 +185,12 @@ type GlobalSymbolTable = SymbolTable -- Domain = all modules
Simple lookups in the symbol table.
\begin{code}
lookupFixityEnv :: IfaceTable -> Name -> Maybe Fixity
lookupFixityEnv tbl name
= case lookupModuleEnv tbl (nameModule name) of
Nothing -> Nothing
Just details -> lookupNameEnv (mi_fixities details) name
lookupTable :: ModuleEnv a -> ModuleEnv a -> Name -> Maybe a
-- We often have two Symbol- or IfaceTables, and want to do a lookup
lookupTable ht pt name
= lookupModuleEnv ht mod `seqMaybe` lookupModuleEnv pt mod
where
mod = nameModule name
\end{code}
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.42 2000/10/24 07:35:01 simonpj Exp $
$Id: Parser.y,v 1.43 2000/10/24 08:40:10 simonpj Exp $
Haskell grammar.
......@@ -332,14 +332,12 @@ topdecl :: { RdrBinding }
| srcloc 'data' ctype '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
(mkTyData DataType cs c ts (reverse $5) (length $5) $6
NoDataPragmas $1))) }
(mkTyData DataType cs c ts (reverse $5) (length $5) $6 $1))) }
| srcloc 'newtype' ctype '=' newconstr deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
(mkTyData NewType cs c ts [$5] 1 $6
NoDataPragmas $1))) }
(mkTyData NewType cs c ts [$5] 1 $6 $1))) }
| srcloc 'class' ctype fds where
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
......@@ -347,8 +345,7 @@ topdecl :: { RdrBinding }
(binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5)
in
returnP (RdrHsDecl (TyClD
(mkClassDecl cs c ts $4 sigs binds
NoClassPragmas $1))) }
(mkClassDecl cs c ts $4 sigs binds $1))) }
| srcloc 'instance' inst_type where
{ let (binds,sigs)
......
......@@ -630,10 +630,6 @@ qdata_name :: { RdrName }
qdata_name : data_name { $1 }
| qdata_fs { mkSysQual dataName $1 }
qdata_names :: { [RdrName] }
qdata_names : { [] }
| qdata_name qdata_names { $1 : $2 }
var_or_data_name :: { RdrName }
: var_name { $1 }
| data_name { $1 }
......@@ -721,7 +717,7 @@ akind :: { Kind }
--------------------------------------------------------------------------
id_info :: { [HsIdInfo RdrName] }
: { [] }
: id_info_item { [$1] }
| id_info_item id_info { $1 : $2 }
id_info_item :: { HsIdInfo RdrName }
......
......@@ -75,9 +75,7 @@ renameModule :: DynFlags -> Finder
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
-> IO (PersistentCompilerState, Maybe ModIface)
-- The mi_decls in the ModIface include
-- ones imported from packages too
-> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
renameModule dflags finder hit hst old_pcs this_module
this_mod@(HsModule _ _ _ _ _ _ loc)
......@@ -110,7 +108,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
case maybe_stuff of {
Nothing -> -- Everything is up to date; no need to recompile further
rnDump [] [] `thenRn` \ dump_action ->
returnRn (Nothing, [], dump_action) ;
returnRn (Nothing, dump_action) ;
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
......
......@@ -98,10 +98,17 @@ loadInterface doc mod from
tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
-- Returns (Just err) if an error happened
-- Guarantees to return with iImpModInfo m --> (... Just cts)
-- (If the load fails, we plug in a vanilla placeholder
-- Guarantees to return with iImpModInfo m --> (..., True)
-- (If the load fails, we plug in a vanilla placeholder)
tryLoadInterface doc_str mod_name from
= getIfacesRn `thenRn` \ ifaces ->
= getHomeIfaceTableRn `thenRn` \ hit ->
getIfacesRn `thenRn` \ ifaces ->
-- Check whether we have it already in the home package
case lookupModuleEnvByName hit mod_name of {
Just _ -> returnRn (ifaces, Nothing) ; -- In the home package
Nothing ->
let
mod_map = iImpModInfo ifaces
mod_info = lookupFM mod_map mod_name
......@@ -205,7 +212,7 @@ tryLoadInterface doc_str mod_name from
in
setIfacesRn new_ifaces `thenRn_`
returnRn (new_ifaces, Nothing)
}}
}}}
-----------------------------------------------------
-- Adding module dependencies from the
......@@ -697,14 +704,11 @@ lookupFixityRn name
-- right away (after all, it's possible that nothing from B will be used).
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
= getHomeIfaceTableRn `thenRn` \ hst ->
case lookupFixityEnv hst name of {
Just fixity -> returnRn fixity ;
Nothing ->
= getHomeIfaceTableRn `thenRn` \ hit ->
loadHomeInterface doc name `thenRn` \ ifaces ->
returnRn (lookupFixityEnv (iPIT ifaces) name `orElse` defaultFixity)
}
case lookupTable hit (iPIT ifaces) name of
Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
Nothing -> returnRn defaultFixity
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
......
......@@ -36,7 +36,6 @@ import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
)
import UniqSupply -- all of it, really
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
import CmdLineOpts ( opt_D_verbose_stg2stg )
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
......@@ -167,12 +166,10 @@ locations.
\begin{code}
bOGUS_LVs :: StgLiveVars
bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
| otherwise =panic "bOGUS_LVs"
bOGUS_LVs = emptyUniqSet
bOGUS_FVs :: [Id]
bOGUS_FVs | opt_D_verbose_stg2stg = []
| otherwise = panic "bOGUS_FVs"
bOGUS_FVs = []
\end{code}
\begin{code}
......
......@@ -28,6 +28,7 @@ import RnMonad ( --RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState )
import BasicTypes ( Fixity )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
......@@ -39,7 +40,6 @@ import Maybes ( maybeToBool, catMaybes )
import Module ( Module )
import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
import RdrName ( RdrName )
--import RnMonad ( FixityEnv )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
......@@ -258,7 +258,7 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons
iBinds = binds,
iLoc = getSrcLoc dfun, iPrags = [] }
where
(tyvars, theta, tau, clas, tys) = splitDFunTy (idType dfun)
(tyvars, theta, clas, tys) = splitDFunTy (idType dfun)
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
......
......@@ -257,9 +257,6 @@ tcCoreExpr (UfNote note expr)
UfInlineCall -> returnTc (Note InlineCall expr')
UfInlineMe -> returnTc (Note InlineMe expr')
UfSCC cc -> returnTc (Note (SCC cc) expr')
tcCoreNote (UfSCC cc) = returnTc (SCC cc)
tcCoreNote UfInlineCall = returnTc InlineCall
\end{code}
\begin{code}
......
......@@ -11,15 +11,15 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), Match(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
import HsPat ( InPat (..) )
import HsMatches ( Match (..) )
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
extractHsTyVars )
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
RenamedTyClDecl, RenamedHsType,
extractHsTyVars, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
......@@ -70,11 +70,10 @@ import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv,
plusNameEnv_C, nameEnvElts )
import FiniteMap ( mapFM )
import SrcLoc ( SrcLoc )
import RnHsSyn -- ( RenamedMonoBinds )
import VarSet ( varSetElems )
import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
import BasicTypes ( NewOrData(..) )
import BasicTypes ( NewOrData(..), Fixity )
import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C,
......
......@@ -44,8 +44,8 @@ import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
import Module ( Module, moduleName, plusModuleEnv )
import Name ( nameOccName, isLocallyDefined, isGlobalName,
toRdrName, nameEnvElts, emptyNameEnv
import Name ( Name, nameOccName, isLocallyDefined, isGlobalName,
toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
)
import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo )
import OccName ( isSysOcc )
......@@ -53,14 +53,14 @@ import TyCon ( TyCon, isClassTyCon )
import Class ( Class )
import PrelNames ( mAIN_Name, mainName )
import UniqSupply ( UniqSupply )
import Maybes ( maybeToBool )
import Maybes ( maybeToBool, thenMaybe )
import Util
import BasicTypes ( EP(..) )
import BasicTypes ( EP(..), Fixity )
import Bag ( Bag, isEmptyBag )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
PackageSymbolTable, DFunId,
TypeEnv, extendTypeEnv,
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..),
TypeEnv, extendTypeEnv, lookupTable,
TyThing(..), groupTyThings )
import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM )
\end{code}
......@@ -107,10 +107,8 @@ typecheckModule dflags this_mod pcs hst hit pit (HsModule mod_name _ _ _ decls _
-> tcModule pcs hst get_fixity this_mod decls unf_env)
get_fixity :: Name -> Maybe Fixity
get_fixity nm
= case lookupFixityEnv hit nm of
Just f -> Just f
Nothing -> lookupFixityEnv pit nm
get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface ->
lookupNameEnv (mi_fixities iface) nm
\end{code}
The internal monster:
......
......@@ -25,7 +25,7 @@ import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClass
)
import TcEnv ( tcExtendTyVarEnv,
tcLookupTyCon, tcLookupClass, tcLookupGlobalId,
TyThing(..), TyThingDetails(..)
TyThingDetails(..)
)
import TcMonad
......
......@@ -15,13 +15,10 @@ module Maybes (
expectJust,
maybeToBool,
failMaB,
failMaybe,
seqMaybe,
returnMaB,
returnMaybe,
thenMaB,
catMaybes
thenMaybe, seqMaybe, returnMaybe, failMaybe, catMaybes,
thenMaB, returnMaB, failMaB
) where
#include "HsVersions.h"
......@@ -104,6 +101,11 @@ seqMaybe :: Maybe a -> Maybe a -> Maybe a
seqMaybe (Just x) _ = Just x
seqMaybe Nothing my = my
thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
thenMaybe ma mb = case ma of
Just x -> mb x
Nothing -> Nothing
returnMaybe :: a -> Maybe a
returnMaybe = Just
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment