X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FLiberateCase.lhs;h=3139b447d8aa9ec16e291590b96a4f154817837e;hb=b374a3eea08e9dcb5d937232ce06bcf1eb3a73df;hp=a5f62f6cb8a733d009e71e22db7d669a1cad2c7e;hpb=f659cb97f97051c2a5fa443e2baaa13fb5db87b9;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index a5f62f6..3139b44 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -12,9 +12,10 @@ 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 Outputable
+import Util             ( notNull )
 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.
@@ -188,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
@@ -219,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
@@ -236,7 +243,7 @@ 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
+  , notNull free_scruts 		-- with free vars scrutinised in RHS
   = Let the_bind (Var v)
 
   | otherwise