[commit: ghc] supercompiler: General cleanup of Core syntax predicates and dead code elimination (6bc0e4b)
Max Bolingbroke <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6bc0e4bd209ae234892a93dd81f371345e7f620b >--------------------------------------------------------------- commit 6bc0e4bd209ae234892a93dd81f371345e7f620b Author: Max Bolingbroke <[email protected]> Date: Mon Aug 1 16:45:40 2011 +0100 General cleanup of Core syntax predicates and dead code elimination >--------------------------------------------------------------- compiler/supercompile/Supercompile/Core/Syntax.hs | 43 +++++++------------- compiler/supercompile/Supercompile/Drive/Match.hs | 4 +- compiler/supercompile/Supercompile/Drive/Split.hs | 2 +- 3 files changed, 18 insertions(+), 31 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index 2080822..8daa1b8 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -11,15 +11,13 @@ import DataCon (DataCon) import Var (TyVar, Var, varName, isTyVar) import Name (Name, nameOccName) import OccName (occNameString) -import Id (Id, idType) +import Id (Id) import Literal (Literal) import Type (Type, mkTyVarTy) -import Coercion (CoVar, Coercion, mkReflCo) +import Coercion (CoVar, Coercion) import PrimOp (PrimOp) import PprCore () -import Data.Traversable (Traversable(traverse)) - data AltCon = DataAlt DataCon [TyVar] [CoVar] [Id] | LiteralAlt Literal | DefaultAlt deriving (Eq, Show) @@ -152,35 +150,24 @@ pPrintPrecApps :: (Outputable a, Outputable b) => Rational -> a -> [b] -> SDoc pPrintPrecApps prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec opPrec e1 <+> hsep (map (pPrintPrec appPrec) es2) -termToValue :: Traversable ann => ann (TermF ann) -> Maybe (ann (ValueF ann)) -termToValue anned_e = traverse termToValue' anned_e - -termToValue' :: TermF ann -> Maybe (ValueF ann) -termToValue' (Value v) = Just v -termToValue' _ = Nothing - +-- Find those things that are Values and cannot be further evaluated. Primarily used to prevent the +-- speculator from re-speculating values, but also as an approximation for what GHC considers a value. termIsValue :: Copointed ann => ann (TermF ann) -> Bool termIsValue = isValue . extract + where + isValue (Value _) = True + isValue (Cast e _) | Value _ <- extract e = True + isValue _ = False -isValue :: TermF ann -> Bool -isValue (Value _) = True -isValue _ = False - +-- Find those things that we are willing to duplicate. termIsCheap :: Copointed ann => ann (TermF ann) -> Bool termIsCheap = isCheap . extract - -isCheap :: Copointed ann => TermF ann -> Bool -isCheap _ | cALL_BY_NAME = True -- A cunning hack. I think this is all that should be required... -isCheap (Var _) = True -isCheap (Value _) = True -isCheap (Case e _ _ []) = isCheap (extract e) -- NB: important for pushing down let-bound applications of ``error'' -isCheap _ = False - -termToVar :: Copointed ann => ann (TermF ann) -> Maybe (Coercion, Var) -termToVar e = case extract e of - Value (Indirect x) -> Just (mkReflCo (idType x), x) - Var x -> Just (mkReflCo (idType x), x) - _ -> Nothing -- FIXME: cast things as well + where + isCheap _ | cALL_BY_NAME = True -- A cunning hack. I think this is all that should be required... + isCheap (Var _) = True + isCheap (Value _) = True + isCheap (Case e _ _ []) = isCheap (extract e) -- NB: important for pushing down let-bound applications of ``error'' + isCheap _ = False varString :: Var -> String varString = nameString . varName diff --git a/compiler/supercompile/Supercompile/Drive/Match.hs b/compiler/supercompile/Supercompile/Drive/Match.hs index dea7435..a53d1d5 100644 --- a/compiler/supercompile/Supercompile/Drive/Match.hs +++ b/compiler/supercompile/Supercompile/Drive/Match.hs @@ -244,7 +244,7 @@ matchLet is_rec rhs_rn2 init_free_eqs xes_l xes_r = matchLoop [] init_free_eqs emptyVarSet emptyVarSet >>= trimBounds (mkVarSet (M.keys h_l)) (mkVarSet (M.keys h_r)) where - markUsed x' e used = if isCheap (annee e) then used else used `extendVarSet` x' + markUsed x' e used = if termIsCheap e then used else used `extendVarSet` x' h_l = M.fromList xes_l h_r = M.fromList xes_r @@ -295,7 +295,7 @@ matchPureHeap rn2 init_free_eqs h_l h_r -- We can account for staticness using the standard generalisation mechanism, and there is no need for the -- matcher to have hacks like that (though we still have to be careful about how we match phantoms). - markUsed x' (_, e) used = if isCheap (annee e) then used else used `extendVarSet` x' + markUsed x' (_, e) used = if termIsCheap e then used else used `extendVarSet` x' matchLoop known [] _ _ = return known matchLoop known ((x_l, x_r):free_eqs) used_l used_r diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs index 678ef1b..65d7c9b 100644 --- a/compiler/supercompile/Supercompile/Drive/Split.hs +++ b/compiler/supercompile/Supercompile/Drive/Split.hs @@ -694,7 +694,7 @@ splitt ctxt_ids (gen_kfs, gen_xs) deeds (Heap h ids, named_k, (scruts, bracketed -- We better not try to push down any bindings that would introduce work-duplication issues | InternallyBound <- howBound hb , Just (_, e) <- heapBindingTerm hb - = if isCheap (annee e) + = if termIsCheap e then hb { howBound = howToBindCheap e } -- Use binding heuristics to determine how to refer to the cheap thing else hb { heapBindingMeaning = Left Nothing, howBound = LambdaBound } -- GHC is unlikely to get any benefit from seeing the binding sites for non-cheap things -- Inline phantom/unfolding stuff verbatim: there is no work duplication issue (the caller would not have created the bindings unless they were safe-for-duplication)