[project @ 2002-11-18 14:22:01 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / TidyPgm.lhs

diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs
index bacbee4..943e32e 100644 (file)
--- a/ghc/compiler/main/TidyPgm.lhs
+++ b/ghc/compiler/main/TidyPgm.lhs
@@ -29,15 +29,15 @@ import BasicTypes   ( isNeverActive )
 import Name            ( getOccName, nameOccName, mkInternalName, mkExternalName, 
                          localiseName, isExternalName, nameSrcLoc
                        )
 import Name            ( getOccName, nameOccName, mkInternalName, mkExternalName, 
                          localiseName, isExternalName, nameSrcLoc
                        )

+import RnEnv           ( lookupOrigNameCache, newExternalName )

 import NameEnv         ( filterNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import Type            ( tidyTopType )
 import Module          ( Module, moduleName )
 import NameEnv         ( filterNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import Type            ( tidyTopType )
 import Module          ( Module, moduleName )

-import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
-                         PersistentRenamerState( prsOrig ),
-                         NameSupply( nsNames, nsUniqs ),
+import HscTypes                ( PersistentCompilerState( pcs_nc ), 
+                         NameCache( nsNames, nsUniqs ),

                          TypeEnv, extendTypeEnvList, typeEnvIds,
                          TypeEnv, extendTypeEnvList, typeEnvIds,

-                         ModDetails(..), TyThing(..)
+                         ModGuts(..), ModGuts, TyThing(..)

                        )
 import FiniteMap       ( lookupFM, addToFM )
 import Maybes          ( orElse )
                        )
 import FiniteMap       ( lookupFM, addToFM )
 import Maybes          ( orElse )

@@ -87,10 +87,10 @@ binder
     [Even non-exported things need system-wide Uniques because the
     byte-code generator builds a single Name->BCO symbol table.]
 
     [Even non-exported things need system-wide Uniques because the
     byte-code generator builds a single Name->BCO symbol table.]
 

-    We use the NameSupply kept in the PersistentRenamerState as the
+    We use the NameCache kept in the PersistentCompilerState as the

     source of such system-wide uniques.
 
     source of such system-wide uniques.
 

-    For external Ids, use the original-name cache in the NameSupply 
+    For external Ids, use the original-name cache in the NameCache

     to ensure that the unique assigned is the same as the Id had 
     in any previous compilation run.
   
     to ensure that the unique assigned is the same as the Id had 
     in any previous compilation run.
   

@@ -119,16 +119,17 @@ throughout, including in unfoldings.  We also tidy binders in
 RHSs, so that they print nicely in interfaces.
 
 \begin{code}
 RHSs, so that they print nicely in interfaces.
 
 \begin{code}

-tidyCorePgm :: DynFlags -> Module
+tidyCorePgm :: DynFlags

            -> PersistentCompilerState
            -> CgInfoEnv                -- Information from the back end,
                                        -- to be splatted into the IdInfo
            -> PersistentCompilerState
            -> CgInfoEnv                -- Information from the back end,
                                        -- to be splatted into the IdInfo

-           -> ModDetails
-           -> IO (PersistentCompilerState, ModDetails)
+           -> ModGuts
+           -> IO (PersistentCompilerState, ModGuts)

 
 

-tidyCorePgm dflags mod pcs cg_info_env
-           (ModDetails { md_types = env_tc, md_insts = insts_tc, 
-                         md_binds = binds_in, md_rules = orphans_in })
+tidyCorePgm dflags pcs cg_info_env
+           mod_impl@(ModGuts { mg_module = mod, 
+                               mg_types = env_tc, mg_insts = insts_tc, 
+                               mg_binds = binds_in, mg_rules = orphans_in })

   = do { showPass dflags "Tidy Core"
 
        ; let ext_ids   = findExternalSet   binds_in orphans_in
   = do { showPass dflags "Tidy Core"
 
        ; let ext_ids   = findExternalSet   binds_in orphans_in

@@ -147,9 +148,7 @@ tidyCorePgm dflags mod pcs cg_info_env
        -- The second exported decl must 'get' the name 'f', so we
        -- have to put 'f' in the avoids list before we get to the first
        -- decl.  tidyTopId then does a no-op on exported binders.
        -- The second exported decl must 'get' the name 'f', so we
        -- have to put 'f' in the avoids list before we get to the first
        -- decl.  tidyTopId then does a no-op on exported binders.

-       ; let   prs           = pcs_PRS pcs
-               orig_ns       = prsOrig prs
-
+       ; let   orig_ns       = pcs_nc pcs

                init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
                avoids        = [getOccName name | bndr <- typeEnvIds env_tc,
                                                   let name = idName bndr,
                init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
                avoids        = [getOccName name | bndr <- typeEnvIds env_tc,
                                                   let name = idName bndr,

@@ -167,8 +166,7 @@ tidyCorePgm dflags mod pcs cg_info_env
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
 
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
 

-       ; let prs' = prs { prsOrig = orig_ns' }
-             pcs' = pcs { pcs_PRS = prs' }
+       ; let pcs' = pcs { pcs_nc = orig_ns' }

 
        ; let final_ids  = [ id 
                           | bind <- tidy_binds
 
        ; let final_ids  = [ id 
                           | bind <- tidy_binds

@@ -184,17 +182,17 @@ tidyCorePgm dflags mod pcs cg_info_env
        ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
              tidy_dfun_ids = map lookup_dfun_id insts_tc
 
        ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
              tidy_dfun_ids = map lookup_dfun_id insts_tc
 

-       ; let tidy_details = ModDetails { md_types = tidy_type_env,
-                                         md_rules = tidy_rules,
-                                         md_insts = tidy_dfun_ids,
-                                         md_binds = tidy_binds }
+       ; let tidy_result = mod_impl { mg_types = tidy_type_env,
+                                      mg_rules = tidy_rules,
+                                      mg_insts = tidy_dfun_ids,
+                                      mg_binds = tidy_binds }

 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
        ; dumpIfSet_core dflags Opt_D_dump_simpl
                "Tidy Core Rules"
                (pprIdRules tidy_rules)
 
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
        ; dumpIfSet_core dflags Opt_D_dump_simpl
                "Tidy Core Rules"
                (pprIdRules tidy_rules)
 

-       ; return (pcs', tidy_details)
+       ; return (pcs', tidy_result)

        }
 
 tidyCoreExpr :: CoreExpr -> IO CoreExpr
        }
 
 tidyCoreExpr :: CoreExpr -> IO CoreExpr

@@ -369,10 +367,10 @@ addExternal (id,rhs) needed
 
 
 \begin{code}
 
 
 \begin{code}

-type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
+type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var)

 
 -- TopTidyEnv: when tidying we need to know
 
 -- TopTidyEnv: when tidying we need to know

---   * ns: The NameSupply, containing a unique supply and any pre-ordained Names.  
+--   * ns: The NameCache, containing a unique supply and any pre-ordained Names.  

 --       These may have arisen because the
 --       renamer read in an interface file mentioning M.$wf, say,
 --       and assigned it unique r77.  If, on this compilation, we've
 --       These may have arisen because the
 --       renamer read in an interface file mentioning M.$wf, say,
 --       and assigned it unique r77.  If, on this compilation, we've

@@ -544,7 +542,7 @@ tidyTopName mod ns occ_env external name
        -- Similarly, we must make sure it has a system-wide Unique, because
        -- the byte-code generator builds a system-wide Name->BCO symbol table
 
        -- Similarly, we must make sure it has a system-wide Unique, because
        -- the byte-code generator builds a system-wide Name->BCO symbol table
 

-  | local  && external = case lookupFM ns_names key of
+  | local  && external = case lookupOrigNameCache ns_names mod occ' of

                           Just orig -> (ns,          occ_env', orig)
                           Nothing   -> (ns_w_global, occ_env', new_external_name)
        -- If we want to externalise a currently-local name, check
                           Just orig -> (ns,          occ_env', orig)
                           Nothing   -> (ns_w_global, occ_env', new_external_name)
        -- If we want to externalise a currently-local name, check

@@ -557,20 +555,17 @@ tidyTopName mod ns occ_env external name
     global          = isExternalName name
     local           = not global
     internal        = not external
     global          = isExternalName name
     local           = not global
     internal        = not external

+    loc                     = nameSrcLoc name

 
     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
 
     (occ_env', occ') = tidyOccName occ_env (nameOccName name)

-    key                     = (moduleName mod, occ')
+

     ns_names        = nsNames ns
     ns_names        = nsNames ns

-    ns_uniqs        = nsUniqs ns
-    (us1, us2)      = splitUniqSupply ns_uniqs
+    (us1, us2)      = splitUniqSupply (nsUniqs ns)

     uniq            = uniqFromSupply us1
     uniq            = uniqFromSupply us1

-    loc                     = nameSrcLoc name
-
-    new_local_name     = mkInternalName  uniq     occ' loc
-    new_external_name  = mkExternalName uniq mod occ' loc  
-
+    new_local_name   = mkInternalName uniq occ' loc

     ns_w_local      = ns { nsUniqs = us2 }
     ns_w_local      = ns { nsUniqs = us2 }

-    ns_w_global             = ns { nsUniqs = us2, nsNames = addToFM ns_names key new_external_name }
+
+    (ns_w_global, new_external_name) = newExternalName ns mod occ' loc

 
 
 ------------  Worker  --------------
 
 
 ------------  Worker  --------------