Skip to content
GitLab
Commit b302643c authored by simonpj's avatar simonpj
Browse files

[project @ 2000-12-08 12:32:15 by simonpj] 

Some renaming in HscTypes
parent fefbb197
Hide whitespace changes
Inline Side-by-side
ghc/compiler/coreSyn/CoreTidy.lhs
View file @ b302643c
......@@ -34,7 +34,7 @@ import Module ( Module, moduleName )
import PrimOp ( PrimOp(..), setCCallUnique )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
OrigNameEnv( origNames ), OrigNameNameEnv
NameSupply( nsNames ), OrigNameCache
)
import UniqSupply
import FiniteMap ( lookupFM, addToFM )
......@@ -122,7 +122,7 @@ tidyCorePgm dflags mod pcs binds_in orphans_in
; let (orphans_out, _)
= initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
; let prs' = prs { prsOrig = orig { origNames = orig_env' } }
; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
pcs' = pcs { pcs_PRS = prs' }
; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
......@@ -140,7 +140,7 @@ tidyCorePgm dflags mod pcs binds_in orphans_in
-- decl. tidyTopId then does a no-op on exported binders.
prs = pcs_PRS pcs
orig = prsOrig prs
orig_env = origNames orig
orig_env = nsNames orig
init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
......@@ -248,7 +248,7 @@ addExternal (id,rhs) needed
\begin{code}
type TopTidyEnv = (UniqSupply, OrigNameNameEnv, TidyOccEnv, VarEnv Var)
type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)
-- TopTidyEnv: when tidying we need to know
-- * orig_env: Any pre-ordained Names. These may have arisen because the
......
ghc/compiler/main/DriverState.hs
View file @ b302643c
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.18 2000/12/05 12:09:43 sewardj Exp $
-- $Id: DriverState.hs,v 1.19 2000/12/08 12:32:15 simonpj Exp $
--
-- Settings for the driver
--
......@@ -23,8 +23,6 @@ import TmpFiles ( newTempName )
import Directory ( removeFile )
#endif
import System
import IO
import List
import Char
import Monad
......@@ -287,7 +285,7 @@ buildCoreToDo = do
])
]
else {- level >= 1 -} return [
else {- opt_level >= 1 -} return [
-- initial simplify: mk specialiser happy: minimum effort please
CoreDoSimplify (isAmongSimpl [
......@@ -359,6 +357,7 @@ buildCoreToDo = do
-- catch it. For the record, the redex is
-- f_el22 (f_el21 r_midblock)
-- Leave out lambda lifting for now
-- "-fsimplify", -- Tidy up results of full laziness
-- "[",
......@@ -368,12 +367,8 @@ buildCoreToDo = do
-- We want CSE to follow the final full-laziness pass, because it may
-- succeed in commoning up things floated out by full laziness.
--
-- CSE must immediately follow a simplification pass, because it relies
-- on the no-shadowing invariant. See comments at the top of CSE.lhs
-- So it must NOT follow float-inwards, which can give rise to shadowing,
-- even if its input doesn't have shadows. Hence putting it between
-- the two passes.
-- CSE used to rely on the no-shadowing invariant, but it doesn't any more
if cse then CoreCSE else CoreDoNothing,
CoreDoFloatInwards,
......@@ -381,11 +376,10 @@ buildCoreToDo = do
-- Case-liberation for -O2. This should be after
-- strictness analysis and the simplification which follows it.
-- ( ($OptLevel != 2)
-- ? ""
-- : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
--
-- "-fliberate-case",
if opt_level >= 2 then
CoreLiberateCase
else
CoreDoNothing,
-- Final clean-up simplification:
CoreDoSimplify (isAmongSimpl [
......
ghc/compiler/main/HscMain.lhs
View file @ b302643c
......@@ -61,7 +61,7 @@ import HscStats ( ppSourceStats )
import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
PersistentRenamerState(..), ModuleLocation(..),
HomeSymbolTable,
OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
NameSupply(..), PackageRuleBase, HomeIfaceTable,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
......@@ -514,11 +514,11 @@ initPersistentCompilerState
)
initPersistentRenamerState :: IO PersistentRenamerState
= do ns <- mkSplitUniqSupply 'r'
= do us <- mkSplitUniqSupply 'r'
return (
PRS { prsOrig = Orig { origNS = ns,
origNames = initOrigNames,
origIParam = emptyFM },
PRS { prsOrig = NameSupply { nsUniqs = us,
nsNames = initOrigNames,
nsIPs = emptyFM },
prsDecls = (emptyNameEnv, 0),
prsInsts = (emptyBag, 0),
prsRules = (emptyBag, 0)
......
ghc/compiler/main/HscTypes.lhs
View file @ b302643c
......@@ -25,7 +25,7 @@ module HscTypes (
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl, IsExported,
OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv,
NameSupply(..), OrigNameCache, OrigIParamCache,
AvailEnv, AvailInfo, GenAvailInfo(..),
PersistentCompilerState(..),
......@@ -457,14 +457,14 @@ type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
data PersistentRenamerState
= PRS { prsOrig :: OrigNameEnv,
= PRS { prsOrig :: NameSupply,
prsDecls :: DeclsMap,
prsInsts :: IfaceInsts,
prsRules :: IfaceRules
}
\end{code}
The OrigNameEnv makes sure that there is just one Unique assigned for
The NameSupply makes sure that there is just one Unique assigned for
each original name; i.e. (module-name, occ-name) pair. The Name is
always stored as a Global, and has the SrcLoc of its binding location.
Actually that's not quite right. When we first encounter the original
......@@ -477,17 +477,17 @@ encounter the occurrence, we may not know the details of the module, so
we just store junk. Then when we find the binding site, we fix it up.
\begin{code}
data OrigNameEnv
= Orig { origNS :: UniqSupply,
data NameSupply
= NameSupply { nsUniqs :: UniqSupply,
-- Supply of uniques
origNames :: OrigNameNameEnv,
nsNames :: OrigNameCache,
-- Ensures that one original name gets one unique
origIParam :: OrigNameIParamEnv
nsIPs :: OrigIParamCache
-- Ensures that one implicit parameter name gets one unique
}
type OrigNameNameEnv = FiniteMap (ModuleName,OccName) Name
type OrigNameIParamEnv = FiniteMap OccName Name
type OrigNameCache = FiniteMap (ModuleName,OccName) Name
type OrigIParamCache = FiniteMap OccName Name
\end{code}
......
ghc/compiler/rename/RnEnv.lhs
View file @ b302643c
......@@ -16,7 +16,7 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, AvailEnv,
AvailInfo, Avails, GenAvailInfo(..), OrigNameEnv(..) )
AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) )
import RnMonad
import Name ( Name, NamedThing(..),
getSrcLoc,
......@@ -71,7 +71,7 @@ newTopBinder mod rdr_name loc
let
occ = rdrNameOcc rdr_name
key = (moduleName mod, occ)
cache = origNames name_supply
cache = nsNames name_supply
in
case lookupFM cache key of
......@@ -86,7 +86,7 @@ newTopBinder mod rdr_name loc
new_name = setNameModuleAndLoc name mod loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {origNames = new_cache}) `thenRn_`
setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_`
traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
......@@ -95,12 +95,12 @@ newTopBinder mod rdr_name loc
-- Even for locally-defined names we use implicitImportProvenance;
-- updateProvenances will set it to rights
Nothing -> let
(us', us1) = splitUniqSupply (origNS name_supply)
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
new_name = mkGlobalName uniq mod occ loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {origNS = us', origNames = new_cache}) `thenRn_`
setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
......@@ -127,17 +127,17 @@ newGlobalName mod_name occ
= getNameSupplyRn `thenRn` \ name_supply ->
let
key = (mod_name, occ)
cache = origNames name_supply
cache = nsNames name_supply
in
case lookupFM cache key of
Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
returnRn name
Nothing -> setNameSupplyRn (name_supply {origNS = us', origNames = new_cache}) `thenRn_`
Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
-- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply (origNS name_supply)
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
mod = mkVanillaModule mod_name
name = mkGlobalName uniq mod occ noSrcLoc
......@@ -146,14 +146,14 @@ newGlobalName mod_name occ
newIPName rdr_name
= getNameSupplyRn `thenRn` \ name_supply ->
let
ipcache = origIParam name_supply
ipcache = nsIPs name_supply
in
case lookupFM ipcache key of
Just name -> returnRn name
Nothing -> setNameSupplyRn (name_supply {origNS = us', origIParam = new_ipcache}) `thenRn_`
Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply (origNS name_supply)
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
name = mkIPName uniq key
new_ipcache = addToFM ipcache key name
......@@ -306,13 +306,13 @@ newLocalsRn rdr_names_w_loc
= getNameSupplyRn `thenRn` \ name_supply ->
let
n = length rdr_names_w_loc
(us', us1) = splitUniqSupply (origNS name_supply)
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniqs = uniqsFromSupply n us1
names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
setNameSupplyRn (name_supply {origNS = us'}) `thenRn_`
setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
returnRn names
......@@ -360,11 +360,11 @@ bindCoreLocalRn rdr_name enclosed_scope
getLocalNameEnv `thenRn` \ name_env ->
getNameSupplyRn `thenRn` \ name_supply ->
let
(us', us1) = splitUniqSupply (origNS name_supply)
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
name = mkLocalName uniq (rdrNameOcc rdr_name) loc
in
setNameSupplyRn (name_supply {origNS = us'}) `thenRn_`
setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
let
new_name_env = extendRdrEnv name_env rdr_name name
in
......
ghc/compiler/rename/RnMonad.lhs
View file @ b302643c
......@@ -37,7 +37,7 @@ import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
import HscTypes ( AvailEnv, lookupType,
OrigNameEnv(..),
NameSupply(..),
WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), IsBootInterface, Avails,
DeclsMap, IfaceInsts, IfaceRules,
......@@ -141,7 +141,7 @@ data RnDown
-- so it has a Module, so it can be looked up
rn_errs :: IORef Messages,
rn_ns :: IORef OrigNameEnv,
rn_ns :: IORef NameSupply,
rn_ifaces :: IORef Ifaces
}
......@@ -402,7 +402,7 @@ renameDerivedCode dflags mod prs thing_inside
-- and that doesn't happen in pragmas etc
do { us <- mkSplitUniqSupply 'r'
; names_var <- newIORef ((prsOrig prs) { origNS = us })
; names_var <- newIORef ((prsOrig prs) { nsUniqs = us })
; errs_var <- newIORef (emptyBag,emptyBag)
; let rn_down = RnDown { rn_dflags = dflags,
......@@ -605,11 +605,11 @@ getTypeEnvRn down l_down = return (rn_done down)
%=====================
\begin{code}
getNameSupplyRn :: RnM d OrigNameEnv
getNameSupplyRn :: RnM d NameSupply
getNameSupplyRn rn_down l_down
= readIORef (rn_ns rn_down)
setNameSupplyRn :: OrigNameEnv -> RnM d ()
setNameSupplyRn :: NameSupply -> RnM d ()
setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
= writeIORef names_var names'
......@@ -617,9 +617,9 @@ getUniqRn :: RnM d Unique
getUniqRn (RnDown {rn_ns = names_var}) l_down
= readIORef names_var >>= \ ns ->
let
(us1,us') = splitUniqSupply (origNS ns)
(us1,us') = splitUniqSupply (nsUniqs ns)
in
writeIORef names_var (ns {origNS = us'}) >>
writeIORef names_var (ns {nsUniqs = us'}) >>
return (uniqFromSupply us1)
\end{code}
......
ghc/compiler/simplCore/LiberateCase.lhs
View file @ b302643c
......@@ -125,7 +125,7 @@ data LibCaseEnv
-- (top-level and imported things have
-- a level of zero)
(IdEnv CoreBind)-- Binds *only* recursively defined
(IdEnv CoreBind) -- Binds *only* recursively defined
-- Ids, to their own binding group,
-- and *only* in their own RHSs
......@@ -187,27 +187,11 @@ libCaseBind env (Rec pairs)
-- processing the rhs with an *un-extended* environment, so
-- that the same process doesn't occur for ever!
extended_env
= addRecBinds env [ (binder, libCase env_body rhs)
| (binder, rhs) <- pairs ]
-- Why "localiseId" above? Because we're creating a new local
-- copy of the original binding. In particular, the original
-- binding might have been for a top-level, and this copy clearly
-- will not be top-level!
-- It is enough to change just the binder, because subsequent
-- simplification will propagate the right info from the binder.
-- Why does it matter? Because the codeGen keeps a separate
-- environment for top-level Ids, and it is disastrous for it
-- to think that something is top-level when it isn't.
--
-- [May 98: all this is now handled by SimplCore.tidyCore]
extended_env = addRecBinds env [ (binder, libCase env_body rhs)
| (binder, rhs) <- pairs ]
rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
lIBERATE_BOMB_SIZE = bombOutSize env
lIBERATE_BOMB_SIZE = bombOutSize env
\end{code}
......@@ -249,7 +233,7 @@ Ids
\begin{code}
libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
| maybeToBool maybe_rec_bind && -- It's a use of a recursive thing
| Just the_bind <- lookupRecId env v, -- It's a use of a recursive thing
there_are_free_scruts -- with free vars scrutinised in RHS
= Let the_bind (Var v)
......@@ -257,12 +241,7 @@ libCaseId env v
= Var v
where
maybe_rec_bind :: Maybe CoreBind -- The binding of the recursive thingy
maybe_rec_bind = lookupRecId env v
Just the_bind = maybe_rec_bind
rec_id_level = lookupLevel env v
rec_id_level = lookupLevel env v
there_are_free_scruts = freeScruts env rec_id_level
\end{code}
......@@ -325,5 +304,5 @@ freeScruts :: LibCaseEnv
freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
= not (null free_scruts)
where
free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
free_scruts = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl]
\end{code}
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