import PrimOp ( PrimOp(..), setCCallUnique )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
- OrigNameEnv( origNames ), OrigNameNameEnv
+ NameSupply( nsNames ), OrigNameCache
)
import UniqSupply
import FiniteMap ( lookupFM, addToFM )
; 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
-- 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,
\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
-----------------------------------------------------------------------------
--- $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
--
import Directory ( removeFile )
#endif
-import System
-import IO
import List
import Char
import Monad
])
]
- else {- level >= 1 -} return [
+ else {- opt_level >= 1 -} return [
-- initial simplify: mk specialiser happy: minimum effort please
CoreDoSimplify (isAmongSimpl [
-- 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
-- "[",
-- 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,
-- 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 [
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 )
)
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)
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl, IsExported,
- OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv,
+ NameSupply(..), OrigNameCache, OrigIParamCache,
AvailEnv, AvailInfo, GenAvailInfo(..),
PersistentCompilerState(..),
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
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}
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,
let
occ = rdrNameOcc rdr_name
key = (moduleName mod, occ)
- cache = origNames name_supply
+ cache = nsNames name_supply
in
case lookupFM cache key of
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
-- 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
= 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
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
= 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
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
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
import HscTypes ( AvailEnv, lookupType,
- OrigNameEnv(..),
+ NameSupply(..),
WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), IsBootInterface, Avails,
DeclsMap, IfaceInsts, IfaceRules,
-- 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
}
-- 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,
%=====================
\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'
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}
-- (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
-- 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}
\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)
= 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}
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}
projects / ghc-hetmet.git / commitdiff