[project @ 2005-03-02 04:35:24 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / LiberateCase.lhs

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index e11950c..3139b44 100644 (file)
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -8,15 +8,14 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_LiberateCaseThreshold )
+import CmdLineOpts     ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
-import Var             ( Id )
+import Var             ( Id, setIdNotExported )
 import VarEnv
-import UniqFM          ( ufmToList )
-import Maybes
 import Outputable
+import Util             ( notNull )
 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.
@@ -145,12 +144,6 @@ data LibCaseEnv
 initEnv :: Int -> LibCaseEnv
 initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
 
-pprEnv :: LibCaseEnv -> SDoc
-pprEnv (LibCaseEnv _ lvl lvl_env _ scruts)
-  = vcat [text "LibCaseEnv" <+> int lvl,
-         fsep (map ppr (ufmToList lvl_env)),
-         fsep (map ppr scruts)]
-
 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 \end{code}
 
@@ -196,8 +189,14 @@ libCaseBind env (Rec pairs)
        -- We extend the rec-env by binding each Id to its rhs, first
        -- 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)
+       --
+       -- Furthermore (subtle!) reset the export flags on the binders so
+       -- that we don't get name clashes on exported things if the 
+       -- local binding floats out to top level.  This is most unlikely
+       -- to happen, since the whole point concerns free variables. 
+       -- But resetting the export flag is right regardless.
+
+    extended_env = addRecBinds env [ (setIdNotExported binder, libCase env_body rhs)
                                   | (binder, rhs) <- pairs ]
 
     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
@@ -227,8 +226,8 @@ libCase env (Let bind body)
   where
     (env_body, bind') = libCaseBind env bind
 
-libCase env (Case scrut bndr alts)
-  = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
+libCase env (Case scrut bndr ty alts)
+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
   where
     env_alts = addBinders env_with_scrut [bndr]
     env_with_scrut = case scrut of
@@ -244,11 +243,8 @@ Ids
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
   | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
-  -- = not (null free_scruts)          -- with free vars scrutinised in RHS
-  = if null free_scruts then
-       pprTrace "No:" (ppr v $$ pprEnv env) (Var v)
-    else
-       pprTrace "Yes:" (ppr v) $ Let the_bind (Var v)
+  , notNull free_scruts                -- with free vars scrutinised in RHS
+  = Let the_bind (Var v)
 
   | otherwise
   = Var v
@@ -306,8 +302,8 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 freeScruts :: LibCaseEnv
           -> LibCaseLevel      -- Level of the recursive Id
-          -> [Id]              -- Ids that are bound ouside the recursive Id, (level <=)
-                               -- but which are scrutinised on the way to this call
+          -> [Id]              -- Ids that are scrutinised between the binding
+                               -- of the recursive Id and here
 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
-  = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl]
+  = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl]
 \end{code}