[project @ 2000-10-24 08:40:09 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreTidy.lhs

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index 3f5626d..6254817 100644 (file)
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -11,22 +11,21 @@ module CoreTidy (
 
 #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 Rules           ( ProtoCoreRule(..) )
+import Rules           ( ProtoCoreRule(..), RuleBase )
 import UsageSPInf       ( doUsageSPInf )
 import VarEnv
 import VarSet
 import Var             ( Id, Var )
-import Id              ( idType, idInfo, idName, 
+import Id              ( idType, idInfo, idName, idSpecialisation,
                          mkVanillaId, mkId, exportWithOrigOccName,
                          idStrictness, setIdStrictness,
                          idDemandInfo, setIdDemandInfo,
                        ) 
 import IdInfo          ( specInfo, setSpecInfo, 
-                         inlinePragInfo, setInlinePragInfo, InlinePragInfo(..),
                          setUnfoldingInfo, setDemandInfo,
                          workerInfo, setWorkerInfo, WorkerInfo(..)
                        )
@@ -35,11 +34,10 @@ import Name         ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
 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 Outputable
 \end{code}
 
 
@@ -52,36 +50,43 @@ import Outputable
 
 Several tasks are done by @tidyCorePgm@
 
-1.  Make certain top-level bindings into Globals. The point is that 
+1. If @opt_UsageSPOn@ then compute usage information (which is
+   needed by Core2Stg).  ** NOTE _scc_ HERE **
+   Do this first, because it may introduce new binders.
+
+2.  Make certain top-level bindings into Globals. The point is that 
     Global things get externally-visible labels at code generation
     time
 
 
-2. Give all binders a nice print-name.  Their uniques aren't changed;
+3. Give all binders a nice print-name.  Their uniques aren't changed;
    rather we give them lexically unique occ-names, so that we can
    safely print the OccNae only in the interface file.  [Bad idea to
    change the uniques, because the code generator makes global labels
    from the uniques for local thunks etc.]
 
-
-3. If @opt_UsageSPOn@ then compute usage information (which is
-   needed by Core2Stg).  ** NOTE _scc_ HERE **
-
 \begin{code}
-tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> [ProtoCoreRule]
+tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
            -> IO ([CoreBind], [ProtoCoreRule])
-tidyCorePgm us module_name binds_in rules
+tidyCorePgm dflags module_name binds_in rulebase_in
   = do
-       beginPass "Tidy Core"
+       us <- mkSplitUniqSupply 'u'
+
+       beginPass dflags "Tidy Core"
 
-       let (tidy_env1, binds_tidy) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in
-           rules_out               = tidyProtoRules tidy_env1 rules
+        binds_in1 <- if opt_UsageSPOn
+                     then _scc_ "CoreUsageSPInf"
+                                doUsageSPInf dflags us binds_in rulebase_in
+                     else return binds_in
 
-        binds_out <- if opt_UsageSPOn
-                     then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy
-                     else return binds_tidy
+       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 dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags || 
+                                   dopt Opt_D_verbose_core2core dflags)
+               binds_out
 
-       endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
        return (binds_out, rules_out)
   where
        -- We also make sure to avoid any exported binders.  Consider
@@ -96,6 +101,11 @@ tidyCorePgm us module_name binds_in rules
     avoids       = [getOccName bndr | bndr <- bindersOfBinds binds_in,
                                       exportWithOrigOccName bndr]
 
+    mk_local_protos :: RuleBase -> [ProtoCoreRule]
+    mk_local_protos (rule_ids, _)
+      = [ProtoCoreRule True id rule | id <- varSetElems rule_ids,
+                                      rule <- rulesRules (idSpecialisation id)]
+
 tidyBind :: Maybe Module               -- (Just m) for top level, Nothing for nested
         -> TidyEnv
         -> CoreBind