X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=8b3d91b7f42d6c9f1c1c8dfe56c7d79cbd2de52b;hb=1cc3d6d110594517f2c7adc72d7b4f99db287277;hp=02a3fab567d6865ac1a8d3d784a0e64c58e0321f;hpb=b1ab4b8a607addc4d097588db5761313c996a41f;p=ghc-hetmet.git diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index 02a3fab..8b3d91b 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -4,6 +4,13 @@ \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/Commentary/CodingStyle#Warnings +-- for details + module LiberateCase ( liberateCase ) where #include "HsVersions.h" @@ -17,14 +24,9 @@ import Rules ( RuleBase ) import UniqSupply ( UniqSupply ) import SimplMonad ( SimplCount, zeroSimplCount ) import Id -import FamInstEnv -import Type -import Coercion -import TyCon import VarEnv import Name ( localiseName ) import Util ( notNull ) -import Data.IORef ( readIORef ) \end{code} The liberate-case transformation @@ -93,9 +95,26 @@ 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 @@ -120,43 +139,6 @@ 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). -Note [Indexed data types] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T :: * -> * - data T Int = TI Int - - f :: T Int -> Bool - f x = case x of { DEFAULT -> } - -We would like to change this to - f x = case x `cast` co of { TI p -> } - -so that can make use of the fact that x is already evaluated to -a TI; and a case on a known data type may be more efficient than a -polymorphic one (not sure this is true any longer). Anyway the former -showed up in Roman's experiments. Example: - foo :: FooT Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -We implement this as part of the liberate-case transformation by -spotting - case of (x::T) tys { DEFAULT -> } -where x :: T tys, and T is a indexed family tycon. Find the -representation type (T77 tys'), and coercion co, and transform to - case `cast` co of (y::T77 tys') - DEFAULT -> let x = y `cast` sym co in - -The "find the representation type" part is done by looking up in the -family-instance environment. - -NB: in fact we re-use x (changing its type) to avoid making a fresh y; -this entails shadowing, but that's ok. %************************************************************************ %* * @@ -169,11 +151,9 @@ liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts) liberateCase hsc_env _ _ guts = do { let dflags = hsc_dflags hsc_env - ; eps <- readIORef (hsc_EPS hsc_env) - ; let fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) ; showPass dflags "Liberate case" - ; let { env = initEnv dflags fam_envs + ; 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 -} @@ -209,7 +189,7 @@ libCaseBind env (Rec pairs) pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] - env_rhs = if all rhs_small_enough rhss then extended_env else env + env_rhs = if all rhs_small_enough pairs 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 @@ -230,8 +210,9 @@ libCaseBind env (Rec pairs) -- 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 + rhs_small_enough (id,rhs) + = idArity id > 0 -- Note [Only functions!] + && couldBeSmallEnoughToInline (bombOutSize env) rhs \end{code} @@ -259,7 +240,7 @@ libCase env (Let bind body) (env_body, bind') = libCaseBind env bind libCase env (Case scrut bndr ty alts) - = mkCase env (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) where env_alts = addBinders (mk_alt_env scrut) [bndr] mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var @@ -269,23 +250,6 @@ libCase env (Case scrut bndr ty alts) libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) \end{code} -\begin{code} -mkCase :: LibCaseEnv -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr --- See Note [Indexed data types] -mkCase env scrut bndr ty [(DEFAULT,_,rhs)] - | Just (tycon, tys) <- splitTyConApp_maybe (idType bndr) - , [(subst, fam_inst)] <- lookupFamInstEnv (lc_fams env) tycon tys - = let - rep_tc = famInstTyCon fam_inst - rep_tys = map (substTyVar subst) (tyConTyVars rep_tc) - bndr' = setIdType bndr (mkTyConApp rep_tc rep_tys) - Just co_tc = tyConFamilyCoercion_maybe rep_tc - co = mkTyConApp co_tc rep_tys - bind = NonRec bndr (Cast (Var bndr') (mkSymCoercion co)) - in mkCase env (Cast scrut co) bndr' ty [(DEFAULT,[],Let bind rhs)] -mkCase env scrut bndr ty alts - = Case scrut bndr ty alts -\end{code} Ids ~~~ @@ -351,7 +315,7 @@ lookupRecId env id = lookupVarEnv (lc_rec_env env) id lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel lookupLevel env id = case lookupVarEnv (lc_lvl_env env) id of - Just lvl -> lc_lvl env + Just lvl -> lvl Nothing -> topLevel freeScruts :: LibCaseEnv @@ -394,7 +358,7 @@ data LibCaseEnv -- to their own binding group, -- and *only* in their own RHSs - lc_scruts :: [(Id,LibCaseLevel)], + lc_scruts :: [(Id,LibCaseLevel)] -- Each of these Ids was scrutinised by an -- enclosing case expression, with the -- specified number of enclosing @@ -402,19 +366,15 @@ data LibCaseEnv -- the Id is bound at a lower level -- than the case expression. The order is -- insignificant; it's a bag really - - lc_fams :: FamInstEnvs - -- Instance env for indexed data types } -initEnv :: DynFlags -> FamInstEnvs -> LibCaseEnv -initEnv dflags fams +initEnv :: DynFlags -> LibCaseEnv +initEnv dflags = LibCaseEnv { lc_size = specThreshold dflags, lc_lvl = 0, lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv, - lc_scruts = [], - lc_fams = fams } + lc_scruts = [] } bombOutSize = lc_size \end{code}