X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=fe1f7585516d7548e2e85cf5a701048ea1b9e1c8;hp=afda3b3fecf92affd04a14a94c5efbad5679c90a;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=21174275446082358e427adec454d7e1c183fd37

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index afda3b3..fe1f758 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -8,18 +8,16 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
-import DynFlags		( DynFlags, DynFlag(..) )
-import StaticFlags	( opt_LiberateCaseThreshold )
-import CoreLint		( showPass, endPass )
+import DynFlags
 import CoreSyn
 import CoreUnfold	( couldBeSmallEnoughToInline )
-import Id		( Id, setIdName, idName, setIdNotExported )
+import Id
 import VarEnv
-import Name		( localiseName )
-import Outputable
 import Util             ( notNull )
 \end{code}
 
+The liberate-case transformation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This module walks over @Core@, and looks for @case@ on free variables.
 The criterion is:
 	if there is case on a free on the route to the recursive call,
@@ -27,59 +25,35 @@ The criterion is:
 
 Example
 
-\begin{verbatim}
-f = \ t -> case v of
-	       V a b -> a : f t
-\end{verbatim}
+   f = \ t -> case v of
+	         V a b -> a : f t
 
 => the inner f is replaced.
 
-\begin{verbatim}
-f = \ t -> case v of
-	       V a b -> a : (letrec
+   f = \ t -> case v of
+	         V a b -> a : (letrec
 				f =  \ t -> case v of
 					       V a b -> a : f t
-			     in f) t
-\end{verbatim}
+			       in f) t
 (note the NEED for shadowing)
 
 => Simplify
 
-\begin{verbatim}
-f = \ t -> case v of
-	       V a b -> a : (letrec
+  f = \ t -> case v of
+	         V a b -> a : (letrec
 				f = \ t -> a : f t
-			     in f t)
-\begin{verbatim}
+			       in f t)
 
 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -87,13 +61,30 @@ Consider this:
     f = \ t -> case (v `cast` co) of
 	         V a b -> a : f t
 
-Exactly the same optimistaion (unrolling one call to f) will work here, 
+Exactly the same optimisation (unrolling one call to f) will work here, 
 despite the cast.  See mk_alt_env in the Case branch of libCase.
 
 
+Note [Only functions!]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider the following code
+
+       f = g (case v of V a b -> a : t f)
+
+where g is expensive. If we aren't careful, liberate case will turn this into
+
+       f = g (case v of
+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
+                                in f)
+             )
+
+Yikes! We evaluate g twice. This leads to a O(2^n) explosion
+if g calls back to the same code recursively.
+
+Solution: make sure that we only do the liberate-case thing on *functions*
+
 To think about (Apr 94)
 ~~~~~~~~~~~~~~
-
 Main worry: duplicating code excessively.  At the moment we duplicate
 the entire binding group once at each recursive call.  But there may
 be a group of recursive calls which share a common set of evaluated
@@ -105,7 +96,6 @@ big.
 
 Data types
 ~~~~~~~~~~
-
 The ``level'' of a binder tells how many
 recursive defns lexically enclose the binding
 A recursive defn "encloses" its RHS, not its
@@ -119,67 +109,32 @@ scope.  For example:
 Here, the level of @f@ is zero, the level of @g@ is one,
 and the level of @h@ is zero (NB not one).
 
-\begin{code}
-type LibCaseLevel = Int
-
-topLevel :: LibCaseLevel
-topLevel = 0
-\end{code}
-
-\begin{code}
-data LibCaseEnv
-  = LibCaseEnv
-	Int			-- Bomb-out size for deciding if
-				-- potential liberatees are too big.
-				-- (passed in from cmd-line args)
-
-	LibCaseLevel		-- Current level
-
-	(IdEnv LibCaseLevel)	-- Binds all non-top-level in-scope Ids
-				-- (top-level and imported things have
-				-- a level of zero)
-
-	(IdEnv CoreBind)	-- Binds *only* recursively defined
-				-- Ids, to their own binding group,
-				-- and *only* in their own RHSs
-
-	[(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
-
-initEnv :: Int -> LibCaseEnv
-initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
-
-bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
-\end{code}
 
+%************************************************************************
+%*									*
+	 Top-level code
+%*									*
+%************************************************************************
 
-Programs
-~~~~~~~~
 \begin{code}
-liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
-liberateCase dflags binds
-  = do {
-	showPass dflags "Liberate case" ;
-	let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
-	endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
-				{- no specific flag for dumping -} 
-    }
+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
 \end{code}
 
+
+%************************************************************************
+%*									*
+	 Main payload
+%*									*
+%************************************************************************
+
 Bindings
 ~~~~~~~~
-
 \begin{code}
 libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
 
@@ -189,37 +144,49 @@ libCaseBind env (NonRec binder rhs)
 libCaseBind env (Rec pairs)
   = (env_body, Rec pairs')
   where
-    (binders, rhss) = unzip pairs
+    binders = map fst pairs
 
     env_body = addBinders env binders
 
     pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
 
-    env_rhs = if all rhs_small_enough rhss then extended_env else env
-
 	-- 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 [ (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
+    env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs)
+			      | (binder, rhs) <- pairs
+ 			      , rhs_small_enough binder rhs ]
+	-- localiseID : see Note [Need to localiseId in libCaseBind]
+		 
+
+    rhs_small_enough id rhs	-- Note [Small enough]
+	=  idArity id > 0	-- Note [Only functions!]
+	&& maybe True (\size -> couldBeSmallEnoughToInline size rhs)
+                      (bombOutSize env)
 \end{code}
 
+Note [Need to localiseId in libCaseBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+	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.
+
+Note [Small enough]
+~~~~~~~~~~~~~~~~~~~
+Consider
+  \fv. letrec
+     	 f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
+     	 g = \y. SMALL...f...
+Then we *can* do liberate-case on g (small RHS) but not for f (too big).
+But we can choose on a item-by-item basis, and that's what the
+rhs_small_enough call in the comprehension for env_rhs does.
 
 Expressions
 ~~~~~~~~~~~
@@ -229,9 +196,10 @@ 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 _   (Coercion co)       = Coercion co
 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
@@ -250,11 +218,14 @@ 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}
 
+
 Ids
 ~~~
 \begin{code}
@@ -270,22 +241,75 @@ 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, scrut_at_lvl) <- lc_scruts env
+       , scrut_bind_lvl <= rec_bind_lvl
+       , scrut_at_lvl > rec_bind_lvl]
+	-- Note [When to specialise]
+	-- Note [Avoiding fruitless liberate-case]
 \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).
+
+Note [Avoiding fruitless liberate-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider also:
+  f = \x. case top_lvl_thing of
+                I# _ -> let g = \y. ... g ...
+                        in ...
+
+Here, top_lvl_thing is scrutinised at a level (1) deeper than its
+binding site (0).  Nevertheless, we do NOT want to specialise the call
+to 'g' because all the structure in its free variables is already
+visible at the definition site for g.  Hence, when considering specialising
+an occurrence of 'g', we want to check that there's a scruted-var v st
+
+   a) v's binding site is *outside* g
+   b) v's scrutinisation site is *inside* g
+
 
+%************************************************************************
+%*									*
+	Utility functions
+%*									*
+%************************************************************************
 
-Utility functions
-~~~~~~~~~~~~~~~~~
 \begin{code}
 addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
-addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
-  = LibCaseEnv bomb lvl lvl_env' rec_env scruts
+addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
+  = env { lc_lvl_env = lvl_env' }
   where
     lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
 
 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
-addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
-  = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, 
+			     lc_rec_env = rec_env}) pairs
+  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }
   where
     lvl'     = lvl + 1
     lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
@@ -295,33 +319,92 @@ addScrutedVar :: LibCaseEnv
 	      -> Id		-- This Id is being scrutinised by a case expression
 	      -> LibCaseEnv
 
-addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
+addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, 
+				lc_scruts = scruts }) scrut_var
   | bind_lvl < lvl
-  = LibCaseEnv bomb lvl lvl_env rec_env scruts'
+  = env { lc_scruts = scruts' }
 	-- Add to scruts iff the scrut_var is being scrutinised at
 	-- a deeper level than its defn
 
   | otherwise = env
   where
-    scruts'  = (scrut_var, lvl) : scruts
+    scruts'  = (scrut_var, bind_lvl, lvl) : scruts
     bind_lvl = case lookupVarEnv lvl_env scrut_var of
 		 Just lvl -> lvl
 		 Nothing  -> topLevel
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
-lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-  = lookupVarEnv rec_env id
+lookupRecId env id = lookupVarEnv (lc_rec_env env) id
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
-lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-  = case lookupVarEnv lvl_env id of
+lookupLevel env id
+  = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel
+\end{code}
 
-freeScruts :: LibCaseEnv
-	   -> LibCaseLevel 	-- Level of 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
-  = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl]
+%************************************************************************
+%*									*
+	 The environment
+%*									*
+%************************************************************************
+
+\begin{code}
+type LibCaseLevel = Int
+
+topLevel :: LibCaseLevel
+topLevel = 0
 \end{code}
+
+\begin{code}
+data LibCaseEnv
+  = LibCaseEnv {
+	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)
+
+	lc_rec_env :: IdEnv CoreBind, 
+		-- Binds *only* recursively defined ids, to their own
+		-- binding group, and *only* in their own RHSs
+
+	lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
+     		-- Each of these Ids was scrutinised by an enclosing
+		-- case expression, at a level deeper than its binding
+		-- level.
+		-- 
+ 		-- The first LibCaseLevel is the *binding level* of
+ 		--   the scrutinised Id, 
+		-- The second is the level *at which it was scrutinised*.
+		--   (see Note [Avoiding fruitless liberate-case])
+		-- The former is a bit redundant, since you could always
+		-- look it up in lc_lvl_env, but it's just cached here
+		-- 
+		-- The order is insignificant; it's a bag really
+		-- 
+		-- There's one element per scrutinisation;
+		--    in principle the same Id may appear multiple times,
+		--    although that'd be unusual:
+		--       case x of { (a,b) -> ....(case x of ...) .. }
+	}
+
+initEnv :: DynFlags -> LibCaseEnv
+initEnv 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}
+