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

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index bd9bac2..3139b44 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -8,13 +8,14 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
-import CoreLint		( beginPass, endPass )
+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 Maybes
+import Outputable
+import Util             ( notNull )
 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.
@@ -40,13 +41,15 @@ f = \ t -> case v of
 \end{verbatim}
 (note the NEED for shadowing)
 
-=> Run Andr\'e's wonder pass ...
+=> Simplify
+
 \begin{verbatim}
 f = \ t -> case v of
 	       V a b -> a : (letrec
 				f = \ t -> a : f t
 			     in f t)
 \begin{verbatim}
+
 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 
@@ -125,7 +128,7 @@ data LibCaseEnv
 				-- (top-level and imported things have
 				-- a level of zero)
 
-	(IdEnv CoreBind)-- Binds *only* recursively defined
+	(IdEnv CoreBind)	-- Binds *only* recursively defined
 				-- Ids, to their own binding group,
 				-- and *only* in their own RHSs
 
@@ -148,14 +151,13 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 Programs
 ~~~~~~~~
 \begin{code}
-liberateCase :: [CoreBind] -> IO [CoreBind]
-liberateCase binds
+liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
+liberateCase dflags binds
   = do {
-	beginPass "Liberate case" ;
+	showPass dflags "Liberate case" ;
 	let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
-	endPass "Liberate case" 
-	 	opt_D_verbose_core2core		{- no specific flag for dumping -} 
-		binds'
+	endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
+				{- no specific flag for dumping -} 
     }
   where
     do_prog env [] = []
@@ -187,28 +189,18 @@ 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)
-			| (binder, rhs) <- pairs ]
-
-	-- Why "localiseId" above?  Because we're creating a new local
-	-- copy of the original binding.  In particular, the original
-	-- binding might have been for a top-level, and this copy clearly
-	-- will not be top-level!
-
-	-- It is enough to change just the binder, because subsequent
-	-- simplification will propagate the right info from the binder.
-
-	-- Why does it matter?  Because the codeGen keeps a separate
-	-- environment for top-level Ids, and it is disastrous for it
-	-- to think that something is top-level when it isn't.
 	--
-	-- [May 98: all this is now handled by SimplCore.tidyCore]
+	-- 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.
 
-    rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
+    extended_env = addRecBinds env [ (setIdNotExported binder, libCase env_body rhs)
+				   | (binder, rhs) <- pairs ]
 
-    lIBERATE_BOMB_SIZE = bombOutSize env
+    rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
+    lIBERATE_BOMB_SIZE   = bombOutSize env
 \end{code}
 
 
@@ -234,13 +226,13 @@ 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 [bndr]
+    env_alts = addBinders env_with_scrut [bndr]
     env_with_scrut = case scrut of
 		  	Var scrut_var -> addScrutedVar env scrut_var
-			other		  -> env
+			other	      -> env
 
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 \end{code}
@@ -250,21 +242,16 @@ Ids
 \begin{code}
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
-  | maybeToBool maybe_rec_bind &&	-- It's a use of a recursive thing
-    there_are_free_scruts		-- with free vars scrutinised in RHS
+  | Just the_bind <- lookupRecId env v	-- It's a use of a recursive thing
+  , notNull free_scruts 		-- with free vars scrutinised in RHS
   = Let the_bind (Var v)
 
   | otherwise
   = Var v
 
   where
-    maybe_rec_bind :: Maybe CoreBind	-- The binding of the recursive thingy
-    maybe_rec_bind = lookupRecId env v
-    Just the_bind  = maybe_rec_bind
-
     rec_id_level = lookupLevel env v
-
-    there_are_free_scruts = freeScruts env rec_id_level
+    free_scruts  = freeScruts env rec_id_level
 \end{code}
 
 
@@ -305,13 +292,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-#ifndef DEBUG
   = lookupVarEnv rec_env id
-#else
-  = case (lookupVarEnv rec_env id) of
-      xxx@(Just _) -> xxx
-      xxx	   -> xxx
-#endif
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
@@ -321,10 +302,8 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 freeScruts :: LibCaseEnv
 	   -> LibCaseLevel 	-- Level of the recursive Id
-	   -> Bool		-- True <=> there is an enclosing case of a variable
-				-- bound outside (ie level <=) the recursive Id.
+	   -> [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
-  = not (null free_scruts)
-  where
-    free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
+  = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl]
 \end{code}