fix Win32 build

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

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 8df30e1..c29a5b9 100644 (file)
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -8,12 +8,14 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
+import DynFlags                ( DynFlags, DynFlag(..) )
+import StaticFlags     ( opt_LiberateCaseThreshold )
 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
-import Var             ( Id )
+import Id              ( Id, setIdName, idName, setIdNotExported )
 import VarEnv
+import Name            ( localiseName )
 import Outputable
 import Util             ( notNull )
 \end{code}
@@ -189,10 +191,22 @@ 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)
+       --
+    extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs)
                                   | (binder, rhs) <- pairs ]
 
+       -- Two subtle things: 
+       -- (a)  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.
+       -- 
+       -- (b)  Make the name an Internal one.  External Names should never be
+       --      nested; if it were floated to the top level, we'd get a name
+       --      clash at code generation time.
+    adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr)))
+
     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
     lIBERATE_BOMB_SIZE   = bombOutSize env
 \end{code}
@@ -220,7 +234,6 @@ libCase env (Let bind body)
   where
     (env_body, bind') = libCaseBind env bind
 
--- gaw 2004
 libCase env (Case scrut bndr ty alts)
   = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
   where