From b302643c51ba129d50d9de26612ba2b9dc60f4e9 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 8 Dec 2000 12:32:16 +0000 Subject: [PATCH] [project @ 2000-12-08 12:32:15 by simonpj] Some renaming in HscTypes --- ghc/compiler/coreSyn/CoreTidy.lhs | 8 +++---- ghc/compiler/main/DriverState.hs | 24 ++++++++------------- ghc/compiler/main/HscMain.lhs | 10 ++++----- ghc/compiler/main/HscTypes.lhs | 18 ++++++++-------- ghc/compiler/rename/RnEnv.lhs | 30 +++++++++++++------------- ghc/compiler/rename/RnMonad.lhs | 14 ++++++------- ghc/compiler/simplCore/LiberateCase.lhs | 35 +++++++------------------------ 7 files changed, 56 insertions(+), 83 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 1e4ac02..9873779 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -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 diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index a825926..1746528 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 [ diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index e185f8e..d6769bc 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 8284e2f..1b79ee2 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 0dc76fe..de24b1a 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -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 diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 2fae263..6a4943d 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -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} diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 57b94be..2ca9e83 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -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} -- 1.7.10.4