X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=4b1055bbede2a34b7f87543207a7939a5befe106;hp=cca213945719b32ec583f8fad3b6eaeb065a0202;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hpb=ad94d40948668032189ad22a0ad741ac1f645f50

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index cca2139..4b1055b 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -4,28 +4,15 @@
 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
--- for details
-
 module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
 import DynFlags
-import HscTypes
-import CoreLint		( showPass, endPass )
 import CoreSyn
 import CoreUnfold	( couldBeSmallEnoughToInline )
-import Rules		( RuleBase )
-import UniqSupply	( UniqSupply )
-import SimplMonad	( SimplCount, zeroSimplCount )
 import Id
 import VarEnv
-import Name		( localiseName )
 import Util             ( notNull )
 \end{code}
 
@@ -60,30 +47,13 @@ Example
 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 
-Other examples we'd like to catch with this kind of transformation
+Note that this deals with *free variables*.  SpecConstr deals with
+*arguments* that are of known form.  E.g.
 
 	last []     = error 
 	last (x:[]) = x
 	last (x:xs) = last xs
 
-We'd like to avoid the redundant pattern match, transforming to
-
-	last [] = error
-	last (x:[]) = x
-	last (x:(y:ys)) = last' y ys
-		where
-		  last' y []     = y
-		  last' _ (y:ys) = last' y ys
-
-	(is this necessarily an improvement)
-
-Similarly drop:
-
-	drop n [] = []
-	drop 0 xs = xs
-	drop n (x:xs) = drop (n-1) xs
-
-Would like to pass n along unboxed.
 	
 Note [Scrutinee with cast]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -147,19 +117,10 @@ and the level of @h@ is zero (NB not one).
 %************************************************************************
 
 \begin{code}
-liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-	     -> IO (SimplCount, ModGuts)
-liberateCase hsc_env _ _ guts
-  = do	{ let dflags = hsc_dflags hsc_env
-
-	; showPass dflags "Liberate case"
-	; let { env = initEnv dflags
-	      ; binds' = do_prog env (mg_binds guts) }
-	; endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
-			{- no specific flag for dumping -} 
-	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
+liberateCase :: DynFlags -> [CoreBind] -> [CoreBind]
+liberateCase dflags binds = do_prog (initEnv dflags) binds
   where
-    do_prog env [] = []
+    do_prog _   [] = []
     do_prog env (bind:binds) = bind' : do_prog env' binds
 			     where
 			       (env', bind') = libCaseBind env bind
@@ -183,7 +144,7 @@ libCaseBind env (NonRec binder rhs)
 libCaseBind env (Rec pairs)
   = (env_body, Rec pairs')
   where
-    (binders, rhss) = unzip pairs
+    (binders, _rhss) = unzip pairs
 
     env_body = addBinders env binders
 
@@ -195,10 +156,10 @@ libCaseBind env (Rec pairs)
 	-- processing the rhs with an *un-extended* environment, so
 	-- that the same process doesn't occur for ever!
 	--
-    extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs)
+    extended_env = addRecBinds env [ (localiseId binder, libCase env_body rhs)
 				   | (binder, rhs) <- pairs ]
 
-	-- Two subtle things: 
+	-- The call to localiseId is needed for two subtle reasons
 	-- (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
@@ -208,11 +169,11 @@ libCaseBind env (Rec pairs)
 	-- (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 (id,rhs)
 	=  idArity id > 0	-- Note [Only functions!]
-	&& couldBeSmallEnoughToInline (bombOutSize env) rhs
+	&& maybe True (\size -> couldBeSmallEnoughToInline size rhs)
+                      (bombOutSize env)
 \end{code}
 
 
@@ -224,9 +185,9 @@ libCase :: LibCaseEnv
 	-> CoreExpr
 	-> CoreExpr
 
-libCase env (Var v)		= libCaseId env v
-libCase env (Lit lit)		= Lit lit
-libCase env (Type ty)		= Type ty
+libCase env (Var v)             = libCaseId env v
+libCase _   (Lit lit)           = Lit lit
+libCase _   (Type ty)           = Type ty
 libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
 libCase env (Note note body)    = Note note (libCase env body)
 libCase env (Cast e co)         = Cast (libCase env e) co
@@ -245,8 +206,10 @@ libCase env (Case scrut bndr ty alts)
     env_alts = addBinders (mk_alt_env scrut) [bndr]
     mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
     mk_alt_env (Cast scrut _)  = mk_alt_env scrut	-- Note [Scrutinee with cast]
-    mk_alt_env otehr	       = env
+    mk_alt_env _    	       = env
 
+libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
+                         -> (AltCon, [CoreBndr], CoreExpr)
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 \end{code}
 
@@ -266,8 +229,39 @@ libCaseId env v
   where
     rec_id_level = lookupLevel env v
     free_scruts  = freeScruts env rec_id_level
+
+freeScruts :: LibCaseEnv
+	   -> LibCaseLevel 	-- Level of the recursive Id
+	   -> [Id]		-- Ids that are scrutinised between the binding
+				-- of the recursive Id and here
+freeScruts env rec_bind_lvl
+  = [v | (v,scrut_bind_lvl) <- lc_scruts env
+       , scrut_bind_lvl <= rec_bind_lvl]
+	-- Note [When to specialise]
 \end{code}
 
+Note [When to specialise]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x. letrec g = \y. case x of
+			   True  -> ... (f a) ...
+			   False -> ... (g b) ...
+
+We get the following levels
+	  f  0
+	  x  1
+	  g  1
+	  y  2  
+
+Then 'x' is being scrutinised at a deeper level than its binding, so
+it's added to lc_sruts:  [(x,1)]  
+
+We do *not* want to specialise the call to 'f', becuase 'x' is not free 
+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).
+
+We *do* want to specialise the call to 'g', because 'x' is free in g.
+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).
+
 
 %************************************************************************
 %*									*
@@ -304,7 +298,7 @@ addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
 
   | otherwise = env
   where
-    scruts'  = (scrut_var, lvl) : scruts
+    scruts'  = (scrut_var, bind_lvl) : scruts
     bind_lvl = case lookupVarEnv lvl_env scrut_var of
 		 Just lvl -> lvl
 		 Nothing  -> topLevel
@@ -317,13 +311,6 @@ lookupLevel env id
   = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel
-
-freeScruts :: LibCaseEnv
-	   -> LibCaseLevel 	-- Level of the recursive Id
-	   -> [Id]		-- Ids that are scrutinised between the binding
-				-- of the recursive Id and here
-freeScruts env rec_bind_lvl
-  = [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl]
 \end{code}
 
 %************************************************************************
@@ -342,40 +329,41 @@ topLevel = 0
 \begin{code}
 data LibCaseEnv
   = LibCaseEnv {
-	lc_size :: Int,		-- Bomb-out size for deciding if
+	lc_size :: Maybe Int,	-- Bomb-out size for deciding if
 				-- potential liberatees are too big.
 				-- (passed in from cmd-line args)
 
 	lc_lvl :: LibCaseLevel,	-- Current level
+		-- The level is incremented when (and only when) going
+		-- inside the RHS of a (sufficiently small) recursive
+		-- function.
 
 	lc_lvl_env :: IdEnv LibCaseLevel,  
-			-- Binds all non-top-level in-scope Ids
-			-- (top-level and imported things have
-			-- a level of zero)
+		-- Binds all non-top-level in-scope Ids (top-level and
+		-- imported things have a level of zero)
 
 	lc_rec_env :: IdEnv CoreBind, 
-			-- Binds *only* recursively defined ids, 
-			-- to their own binding group,
-			-- and *only* in their own RHSs
+		-- Binds *only* recursively defined ids, to their own
+		-- binding group, and *only* in their own RHSs
 
 	lc_scruts :: [(Id,LibCaseLevel)]
-     			-- Each of these Ids was scrutinised by an
-			-- enclosing case expression, with the
-			-- specified number of enclosing
-			-- recursive bindings; furthermore,
-			-- the Id is bound at a lower level
-			-- than the case expression.  The order is
-			-- insignificant; it's a bag really
+     		-- Each of these Ids was scrutinised by an enclosing
+		-- case expression, at a level deeper than its binding
+		-- level.  The LibCaseLevel recorded here is the *binding
+		-- level* of the scrutinised Id.
+		-- 
+		-- The order is insignificant; it's a bag really
 	}
 
 initEnv :: DynFlags -> LibCaseEnv
 initEnv dflags 
-  = LibCaseEnv { lc_size = specThreshold dflags,
+  = LibCaseEnv { lc_size = liberateCaseThreshold dflags,
 		 lc_lvl = 0,
 		 lc_lvl_env = emptyVarEnv, 
 		 lc_rec_env = emptyVarEnv,
 		 lc_scruts = [] }
 
+bombOutSize :: LibCaseEnv -> Maybe Int
 bombOutSize = lc_size
 \end{code}