projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
323fee1
)
[project @ 2000-10-24 08:40:09 by simonpj]
author
simonpj
<unknown>
Tue, 24 Oct 2000 08:40:11 +0000
(08:40 +0000)
committer
simonpj
<unknown>
Tue, 24 Oct 2000 08:40:11 +0000
(08:40 +0000)
Small wibbles
20 files changed:
ghc/compiler/absCSyn/PprAbsC.lhs
patch
|
blob
|
history
ghc/compiler/codeGen/CgClosure.lhs
patch
|
blob
|
history
ghc/compiler/codeGen/CgHeapery.lhs
patch
|
blob
|
history
ghc/compiler/coreSyn/CoreTidy.lhs
patch
|
blob
|
history
ghc/compiler/deSugar/DsForeign.lhs
patch
|
blob
|
history
ghc/compiler/deSugar/DsMonad.lhs
patch
|
blob
|
history
ghc/compiler/deSugar/Match.lhs
patch
|
blob
|
history
ghc/compiler/main/HscMain.lhs
patch
|
blob
|
history
ghc/compiler/main/HscTypes.lhs
patch
|
blob
|
history
ghc/compiler/parser/Parser.y
patch
|
blob
|
history
ghc/compiler/rename/ParseIface.y
patch
|
blob
|
history
ghc/compiler/rename/Rename.lhs
patch
|
blob
|
history
ghc/compiler/rename/RnIfaces.lhs
patch
|
blob
|
history
ghc/compiler/stgSyn/CoreToStg.lhs
patch
|
blob
|
history
ghc/compiler/typecheck/TcDeriv.lhs
patch
|
blob
|
history
ghc/compiler/typecheck/TcIfaceSig.lhs
patch
|
blob
|
history
ghc/compiler/typecheck/TcInstDcls.lhs
patch
|
blob
|
history
ghc/compiler/typecheck/TcModule.lhs
patch
|
blob
|
history
ghc/compiler/typecheck/TcTyDecls.lhs
patch
|
blob
|
history
ghc/compiler/utils/Maybes.lhs
patch
|
blob
|
history
diff --git
a/ghc/compiler/absCSyn/PprAbsC.lhs
b/ghc/compiler/absCSyn/PprAbsC.lhs
index
2ad4595
..
5eb0cc1
100644
(file)
--- a/
ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/
ghc/compiler/absCSyn/PprAbsC.lhs
@@
-56,6
+56,7
@@
import UniqSet ( emptyUniqSet, elementOfUniqSet,
import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
+import GlaExts
import Util ( nOfThem )
import ST
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 (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")
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!"
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
pprUnionTag :: PrimRep -> SDoc
diff --git
a/ghc/compiler/codeGen/CgClosure.lhs
b/ghc/compiler/codeGen/CgClosure.lhs
index
34a84cc
..
b2bd1fe
100644
(file)
--- a/
ghc/compiler/codeGen/CgClosure.lhs
+++ b/
ghc/compiler/codeGen/CgClosure.lhs
@@
-1,7
+1,7
@@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%
% (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}
%
\section[CgClosure]{Code generation for closures}
@@
-57,7
+57,8
@@
import Outputable
import Name ( nameOccName )
import OccName ( occNameFS )
import Name ( nameOccName )
import OccName ( occNameFS )
-
+import FastTypes ( iBox )
+
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
@@
-539,7
+540,7
@@
argSatisfactionCheck closure_info arg_regs
getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
- off = I# sp
+ off = iBox sp
rel_arg = mkIntCLit off
in
ASSERT(off /= 0)
rel_arg = mkIntCLit off
in
ASSERT(off /= 0)
diff --git
a/ghc/compiler/codeGen/CgHeapery.lhs
b/ghc/compiler/codeGen/CgHeapery.lhs
index
6ec7c84
..
be8e4e0
100644
(file)
--- a/
ghc/compiler/codeGen/CgHeapery.lhs
+++ b/
ghc/compiler/codeGen/CgHeapery.lhs
@@
-1,7
+1,7
@@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%
% (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}
%
\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
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
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
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,
| 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,
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
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,
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.)
-- 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.
-- 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
| 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)
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-}]
| 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
CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
-- FloatReg1
- [FloatReg ILIT(1)] ->
+ [FloatReg 1#] ->
CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-- DblReg1
CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-- DblReg1
- [DoubleReg ILIT(1)] ->
+ [DoubleReg 1#] ->
CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-- LngReg1
CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-- LngReg1
- [LongReg _ ILIT(1)] ->
+ [LongReg _ 1#] ->
CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
#ifdef DEBUG
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 [
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
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
liveness_mask = mkRegLiveness regs
yield_code =
absC (CMacroStmt GRAN_YIELD
- [mkIntCLit (IBOX(word2Int# liveness_mask))])
+ [mkIntCLit (I# (word2Int# liveness_mask))])
\end{code}
\begin{code}
\end{code}
\begin{code}
diff --git
a/ghc/compiler/coreSyn/CoreTidy.lhs
b/ghc/compiler/coreSyn/CoreTidy.lhs
index
3fbdc74
..
6254817
100644
(file)
--- a/
ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/
ghc/compiler/coreSyn/CoreTidy.lhs
@@
-11,7
+11,7
@@
module CoreTidy (
#include "HsVersions.h"
#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 )
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 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 )
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}
from the uniques for local thunks etc.]
\begin{code}
-tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> RuleBase
+tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
-> IO ([CoreBind], [ProtoCoreRule])
-> IO ([CoreBind], [ProtoCoreRule])
-tidyCorePgm us module_name binds_in rulebase_in
+tidyCorePgm dflags module_name binds_in rulebase_in
= do
= do
- beginPass "Tidy Core"
+ us <- mkSplitUniqSupply 'u'
+
+ beginPass dflags "Tidy Core"
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
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)
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
return (binds_out, rules_out)
where
-- We also make sure to avoid any exported binders. Consider
diff --git
a/ghc/compiler/deSugar/DsForeign.lhs
b/ghc/compiler/deSugar/DsForeign.lhs
index
12df319
..
a5dbf53
100644
(file)
--- a/
ghc/compiler/deSugar/DsForeign.lhs
+++ b/
ghc/compiler/deSugar/DsForeign.lhs
@@
-32,18
+32,13
@@
import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
import Type ( unUsgTy, repType,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
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 TysPrim ( addrPrimTy )
-import PrelNames ( Uniquable(..), hasKey,
- ioTyConKey, deRefStablePtrName, returnIOIdKey,
- bindIOName,
- returnIOName, makeStablePtrName
+import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName,
+ bindIOName, returnIOName, makeStablePtrName
)
import Outputable
)
import Outputable
diff --git
a/ghc/compiler/deSugar/DsMonad.lhs
b/ghc/compiler/deSugar/DsMonad.lhs
index
5516cef
..
ecddeb4
100644
(file)
--- a/
ghc/compiler/deSugar/DsMonad.lhs
+++ b/
ghc/compiler/deSugar/DsMonad.lhs
@@
-37,7
+37,6
@@
import Type ( Type )
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
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(..),
import Util ( zipWithEqual )
import Name ( Name, lookupNameEnv )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..),
diff --git
a/ghc/compiler/deSugar/Match.lhs
b/ghc/compiler/deSugar/Match.lhs
index
f65de3c
..
67f4851
100644
(file)
--- a/
ghc/compiler/deSugar/Match.lhs
+++ b/
ghc/compiler/deSugar/Match.lhs
@@
-8,7
+8,7
@@
module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
#include "HsVersions.h"
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
+import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
import DsHsSyn ( outPatType )
import HsSyn
import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
import DsHsSyn ( outPatType )
diff --git
a/ghc/compiler/main/HscMain.lhs
b/ghc/compiler/main/HscMain.lhs
index
797c850
..
2c1be78
100644
(file)
--- a/
ghc/compiler/main/HscMain.lhs
+++ b/
ghc/compiler/main/HscMain.lhs
@@
-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 '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
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
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
simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
-- Run the occurrence analyser one last time, so that
diff --git
a/ghc/compiler/main/HscTypes.lhs
b/ghc/compiler/main/HscTypes.lhs
index
ee3c9e2
..
1b34ec0
100644
(file)
--- a/
ghc/compiler/main/HscTypes.lhs
+++ b/
ghc/compiler/main/HscTypes.lhs
@@
-9,7
+9,8
@@
module HscTypes (
ModDetails(..), ModIface(..), GlobalSymbolTable,
HomeSymbolTable, PackageSymbolTable,
ModDetails(..), ModIface(..), GlobalSymbolTable,
HomeSymbolTable, PackageSymbolTable,
- HomeIfaceTable, PackageIfaceTable,
+ HomeIfaceTable, PackageIfaceTable,
+ lookupTable,
IfaceDecls(..),
IfaceDecls(..),
@@
-19,8
+20,6
@@
module HscTypes (
TypeEnv, extendTypeEnv, lookupTypeEnv,
TypeEnv, extendTypeEnv, lookupTypeEnv,
- lookupFixityEnv,
-
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl,
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 FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
import Bag ( Bag )
+import Maybes ( seqMaybe )
import UniqFM ( UniqFM )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
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_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),
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}
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}
\end{code}
diff --git
a/ghc/compiler/parser/Parser.y
b/ghc/compiler/parser/Parser.y
index
f228ea8
..
d82fe3f
100644
(file)
--- a/
ghc/compiler/parser/Parser.y
+++ b/
ghc/compiler/parser/Parser.y
@@
-1,6
+1,6
@@
{-
-----------------------------------------------------------------------------
{-
-----------------------------------------------------------------------------
-$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.
Haskell grammar.
@@
-332,14
+332,12
@@
topdecl :: { RdrBinding }
| srcloc 'data' ctype '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
| 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
| 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) ->
| 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
(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)
| srcloc 'instance' inst_type where
{ let (binds,sigs)
diff --git
a/ghc/compiler/rename/ParseIface.y
b/ghc/compiler/rename/ParseIface.y
index
94f29f1
..
a51631f
100644
(file)
--- a/
ghc/compiler/rename/ParseIface.y
+++ b/
ghc/compiler/rename/ParseIface.y
@@
-630,10
+630,6
@@
qdata_name :: { RdrName }
qdata_name : data_name { $1 }
| qdata_fs { mkSysQual dataName $1 }
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 }
var_or_data_name :: { RdrName }
: var_name { $1 }
| data_name { $1 }
@@
-721,7
+717,7
@@
akind :: { Kind }
--------------------------------------------------------------------------
id_info :: { [HsIdInfo RdrName] }
--------------------------------------------------------------------------
id_info :: { [HsIdInfo RdrName] }
- : { [] }
+ : id_info_item { [$1] }
| id_info_item id_info { $1 : $2 }
id_info_item :: { HsIdInfo RdrName }
| id_info_item id_info { $1 : $2 }
id_info_item :: { HsIdInfo RdrName }
diff --git
a/ghc/compiler/rename/Rename.lhs
b/ghc/compiler/rename/Rename.lhs
index
0cc7b3f
..
2f14e0d
100644
(file)
--- a/
ghc/compiler/rename/Rename.lhs
+++ b/
ghc/compiler/rename/Rename.lhs
@@
-75,9
+75,7
@@
renameModule :: DynFlags -> Finder
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
-> 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)
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 ->
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) ->
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
diff --git
a/ghc/compiler/rename/RnIfaces.lhs
b/ghc/compiler/rename/RnIfaces.lhs
index
4452723
..
6ff626d
100644
(file)
--- a/
ghc/compiler/rename/RnIfaces.lhs
+++ b/
ghc/compiler/rename/RnIfaces.lhs
@@
-98,10
+98,17
@@
loadInterface doc mod from
tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
-- Returns (Just err) if an error happened
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
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
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)
in
setIfacesRn new_ifaces `thenRn_`
returnRn (new_ifaces, Nothing)
- }}
+ }}}
-----------------------------------------------------
-- Adding module dependencies from the
-----------------------------------------------------
-- 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.
-- 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 ->
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}
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
diff --git
a/ghc/compiler/stgSyn/CoreToStg.lhs
b/ghc/compiler/stgSyn/CoreToStg.lhs
index
73712b1
..
bcb1d9d
100644
(file)
--- a/
ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/
ghc/compiler/stgSyn/CoreToStg.lhs
@@
-36,7
+36,6
@@
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
)
import UniqSupply -- all of it, really
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
)
import UniqSupply -- all of it, really
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( opt_D_verbose_stg2stg )
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
@@
-167,12
+166,10
@@
locations.
\begin{code}
bOGUS_LVs :: StgLiveVars
\begin{code}
bOGUS_LVs :: StgLiveVars
-bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
- | otherwise =panic "bOGUS_LVs"
+bOGUS_LVs = emptyUniqSet
bOGUS_FVs :: [Id]
bOGUS_FVs :: [Id]
-bOGUS_FVs | opt_D_verbose_stg2stg = []
- | otherwise = panic "bOGUS_FVs"
+bOGUS_FVs = []
\end{code}
\begin{code}
\end{code}
\begin{code}
diff --git
a/ghc/compiler/typecheck/TcDeriv.lhs
b/ghc/compiler/typecheck/TcDeriv.lhs
index
a4a13d0
..
dac3e4a
100644
(file)
--- a/
ghc/compiler/typecheck/TcDeriv.lhs
+++ b/
ghc/compiler/typecheck/TcDeriv.lhs
@@
-28,6
+28,7
@@
import RnMonad ( --RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState )
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 )
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 Module ( Module )
import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
import RdrName ( RdrName )
---import RnMonad ( FixityEnv )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
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
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
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
diff --git
a/ghc/compiler/typecheck/TcIfaceSig.lhs
b/ghc/compiler/typecheck/TcIfaceSig.lhs
index
f1a747f
..
f03bb4f
100644
(file)
--- a/
ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/
ghc/compiler/typecheck/TcIfaceSig.lhs
@@
-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')
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}
\end{code}
\begin{code}
diff --git
a/ghc/compiler/typecheck/TcInstDcls.lhs
b/ghc/compiler/typecheck/TcInstDcls.lhs
index
245e762
..
571ebf7
100644
(file)
--- a/
ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/
ghc/compiler/typecheck/TcInstDcls.lhs
@@
-11,15
+11,15
@@
module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
import CmdLineOpts ( DynFlag(..), dopt )
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 )
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 )
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 )
plusNameEnv_C, nameEnvElts )
import FiniteMap ( mapFM )
import SrcLoc ( SrcLoc )
-import RnHsSyn -- ( RenamedMonoBinds )
import VarSet ( varSetElems )
import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
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,
import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C,
diff --git
a/ghc/compiler/typecheck/TcModule.lhs
b/ghc/compiler/typecheck/TcModule.lhs
index
cd9aaca
..
a47d783
100644
(file)
--- a/
ghc/compiler/typecheck/TcModule.lhs
+++ b/
ghc/compiler/typecheck/TcModule.lhs
@@
-44,8
+44,8
@@
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
import Module ( Module, moduleName, plusModuleEnv )
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 )
)
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 Class ( Class )
import PrelNames ( mAIN_Name, mainName )
import UniqSupply ( UniqSupply )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, thenMaybe )
import Util
import Util
-import BasicTypes ( EP(..) )
+import BasicTypes ( EP(..), Fixity )
import Bag ( Bag, isEmptyBag )
import Outputable
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}
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
-> 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:
\end{code}
The internal monster:
diff --git
a/ghc/compiler/typecheck/TcTyDecls.lhs
b/ghc/compiler/typecheck/TcTyDecls.lhs
index
0392d34
..
c44fef2
100644
(file)
--- a/
ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/
ghc/compiler/typecheck/TcTyDecls.lhs
@@
-25,7
+25,7
@@
import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClass
)
import TcEnv ( tcExtendTyVarEnv,
tcLookupTyCon, tcLookupClass, tcLookupGlobalId,
)
import TcEnv ( tcExtendTyVarEnv,
tcLookupTyCon, tcLookupClass, tcLookupGlobalId,
- TyThing(..), TyThingDetails(..)
+ TyThingDetails(..)
)
import TcMonad
)
import TcMonad
diff --git
a/ghc/compiler/utils/Maybes.lhs
b/ghc/compiler/utils/Maybes.lhs
index
abaf1c1
..
3f94d34
100644
(file)
--- a/
ghc/compiler/utils/Maybes.lhs
+++ b/
ghc/compiler/utils/Maybes.lhs
@@
-15,13
+15,10
@@
module Maybes (
expectJust,
maybeToBool,
expectJust,
maybeToBool,
- failMaB,
- failMaybe,
- seqMaybe,
- returnMaB,
- returnMaybe,
- thenMaB,
- catMaybes
+ thenMaybe, seqMaybe, returnMaybe, failMaybe, catMaybes,
+
+ thenMaB, returnMaB, failMaB
+
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
@@
-104,6
+101,11
@@
seqMaybe :: Maybe a -> Maybe a -> Maybe a
seqMaybe (Just x) _ = Just x
seqMaybe Nothing my = my
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
returnMaybe :: a -> Maybe a
returnMaybe = Just