X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=8b3d91b7f42d6c9f1c1c8dfe56c7d79cbd2de52b;hb=1cc3d6d110594517f2c7adc72d7b4f99db287277;hp=31063d3b2491b7a32fd859137fc8904aefa32cdd;hpb=7aa3f5247ae454b10b61e2f28a9431f0889a8cff;p=ghc-hetmet.git diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index 31063d3..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,15 +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 Outputable import Util ( notNull ) -import Data.IORef ( readIORef ) \end{code} The liberate-case transformation @@ -90,13 +91,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 @@ -108,7 +126,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 @@ -122,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. %************************************************************************ %* * @@ -171,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 -} @@ -211,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 @@ -232,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} @@ -261,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 @@ -271,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 ~~~ @@ -353,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 @@ -396,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 @@ -404,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 - = LibCaseEnv { lc_size = libCaseThreshold dflags, +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}