From 037bcc3f94a9ba6de6dbbdf49dd632dfad2a9751 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 28 Jan 2020 20:12:40 +0100 Subject: [PATCH 1/3] ES: added DFE --- grin/grin.cabal | 2 + .../Optimising/DeadFunctionElimination.hs | 83 ++++++++++++ .../Optimising/DeadFunctionEliminationSpec.hs | 123 ++++++++++++++++++ 3 files changed, 208 insertions(+) create mode 100644 grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs create mode 100644 grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index ab2f7d7f..b98c04f0 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -148,6 +148,7 @@ library Transformations.ExtendedSyntax.StaticSingleAssignment Transformations.ExtendedSyntax.Optimising.CopyPropagation Transformations.ExtendedSyntax.Optimising.CSE + Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination @@ -303,6 +304,7 @@ test-suite grin-test Transformations.ExtendedSyntax.StaticSingleAssignmentSpec Transformations.ExtendedSyntax.Optimising.CopyPropagationSpec Transformations.ExtendedSyntax.Optimising.CSESpec + Transformations.ExtendedSyntax.Optimising.DeadFunctionEliminationSpec Transformations.ExtendedSyntax.Optimising.EvaluatedCaseEliminationSpec Transformations.ExtendedSyntax.Optimising.TrivialCaseEliminationSpec diff --git a/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs b/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs new file mode 100644 index 00000000..0cfb203f --- /dev/null +++ b/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase, RecordWildCards #-} +module Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination where + +import Data.Set (Set) +import Data.Map (Map) +import Data.Vector (Vector) + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Vector as Vec + +import Data.List +import Data.Maybe +import Data.Monoid + +import qualified Data.Foldable +import Data.Functor.Foldable as Foldable + +import Lens.Micro +import Lens.Micro.Platform + +import Control.Monad.Extra +import Control.Monad.State +import Control.Monad.Trans.Except + +import Grin.Grin +import Grin.Pretty +import Grin.TypeEnv +import Transformations.Util +import AbstractInterpretation.LiveVariable.Result as LVA + + +type Trf = Except String + +runTrf :: Trf a -> Either String a +runTrf = runExcept + +deadFunctionElimination :: LVAResult -> TypeEnv -> Exp -> Either String Exp +deadFunctionElimination lvaResult tyEnv = runTrf . + (deleteDeadFunctions lvaResult >=> replaceDeadFunApps lvaResult tyEnv) + +deleteDeadFunctions :: LVAResult -> Exp -> Trf Exp +deleteDeadFunctions lvaResult (Program exts defs) = + fmap (Program exts) $ filterM isFunDefLiveM defs where + + isFunDefLiveM :: Exp -> Trf Bool + isFunDefLiveM (Def f _ _) = fmap not $ isRemovableM lvaResult f + isFunDefLiveM e = throwE $ "DFE: " ++ show (PP e) ++ " is not a function definition" + + +replaceDeadFunApps :: LVAResult -> TypeEnv -> Exp -> Trf Exp +replaceDeadFunApps lvaResult tyEnv = cataM alg where + + alg :: ExpF Exp -> Trf Exp + alg = replaceAppWithUndefined lvaResult tyEnv . embed + +replaceAppWithUndefined :: LVAResult -> TypeEnv -> Exp -> Trf Exp +replaceAppWithUndefined lvaResult TypeEnv{..} app@(SApp f _) = do + isRemovable <- isRemovableM lvaResult f + if isRemovable then do + (retTy,_) <- lookupExcept (notFoundInTyEnv f) f _function + pure $ SReturn $ Undefined (simplifyType retTy) + else + pure app + where notFoundInTyEnv f = "DFE: Function " ++ show (PP f) ++ " not found in type env" +replaceAppWithUndefined _ _ e = pure e + +isRemovableM :: LVAResult -> Name -> Trf Bool +isRemovableM lvaResult f = (&&) <$> isFunDeadM lvaResult f + <*> hasNoSideEffectsM lvaResult f + +hasNoSideEffectsM :: LVAResult -> Name -> Trf Bool +hasNoSideEffectsM LVAResult{..} f = fmap (not . _hasEffect) + . lookupExcept (noLiveness f) f + $ _functionEff + +isFunDeadM :: LVAResult -> Name -> Trf Bool +isFunDeadM LVAResult{..} f = fmap isFunDead + . lookupExcept (noLiveness f) f + $ _functionLv + +noEffect f = "DFE: Function " ++ show (PP f) ++ " not found in effect map" +noLiveness f = "DFE: Function " ++ show (PP f) ++ " not found in liveness map" diff --git a/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs b/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs new file mode 100644 index 00000000..539d697e --- /dev/null +++ b/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module Transformations.ExtendedSyntax.Optimising.DeadFunctionEliminationSpec where + +import Test.Hspec +import Test.Hspec.PipelineExample +import Pipeline.Pipeline hiding (pipeline) +import Grin.TH + + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + describe "Dead Function Elimination" $ do + + let deadFunctionEliminationPipeline = + [ T DeadFunctionElimination + ] + + it "app_side_effect_1" $ do + let before = [prog| + grinMain = + p0 <- store (CInt 0) + y0 <- f p0 + y1 <- fetch p0 + pure y1 + + f p = + update p (CInt 1) + pure 0 + |] + + let after = [prog| + grinMain = + p0 <- store (CInt 0) + y0 <- f p0 + y1 <- fetch p0 + pure y1 + + f p = + update p (CInt 1) + pure 0 + |] + pipelineSrc before after deadFunctionEliminationPipeline + + it "mutually_recursive" $ do + let before = [prog| + grinMain = pure 0 + f x = g x + g y = f y + |] + + let after = [prog| + grinMain = pure 0 + |] + pipelineSrc before after deadFunctionEliminationPipeline + + it "replace_node" $ do + let before = [prog| + grinMain = + n0 <- f 0 + pure 0 + + f x = + p <- store (CInt 5) + pure (CNode p) + |] + + let after = [prog| + grinMain = + n0 <- pure (#undefined :: {CNode[#ptr]}) + pure 0 + |] + pipelineSrc before after deadFunctionEliminationPipeline + + it "replace_simple_type" $ do + let before = [prog| + grinMain = + y0 <- f 0 + pure 0 + + f x = pure x + |] + + let after = [prog| + grinMain = + y0 <- pure (#undefined :: T_Int64) + pure 0 + |] + pipelineSrc before after deadFunctionEliminationPipeline + + it "simple" $ do + let before = [prog| + grinMain = pure 0 + + f x = pure x + |] + + let after = [prog| + grinMain = pure 0 + |] + pipelineSrc before after deadFunctionEliminationPipeline + + it "true_side_effect_min" $ do + let before = [prog| + grinMain = + result_main <- Main.main1 $ + pure () + + Main.main1 = + _prim_int_print $ 1 + |] + + let after = [prog| + grinMain = + result_main <- Main.main1 $ + pure () + + Main.main1 = + _prim_int_print $ 1 + |] + pipelineSrc before after deadFunctionEliminationPipeline From 967ebcb72b98747c745b0395c58257025543ff01 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 28 Jan 2020 20:58:20 +0100 Subject: [PATCH 2/3] ES: fixed imports for DFE --- .../Optimising/DeadFunctionElimination.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs b/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs index 0cfb203f..49718405 100644 --- a/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs +++ b/grin/src/Transformations/ExtendedSyntax/Optimising/DeadFunctionElimination.hs @@ -23,11 +23,11 @@ import Control.Monad.Extra import Control.Monad.State import Control.Monad.Trans.Except -import Grin.Grin -import Grin.Pretty -import Grin.TypeEnv -import Transformations.Util -import AbstractInterpretation.LiveVariable.Result as LVA +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.Pretty +import Grin.ExtendedSyntax.TypeEnv +import Transformations.ExtendedSyntax.Util +import AbstractInterpretation.ExtendedSyntax.LiveVariable.Result as LVA type Trf = Except String From d0c1d37e562a1d8d06662be002a29920b8b3674c Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 28 Jan 2020 20:58:34 +0100 Subject: [PATCH 3/3] ES: fixed tests for DFE --- .../Optimising/DeadFunctionEliminationSpec.hs | 72 ++++++++++++------- 1 file changed, 48 insertions(+), 24 deletions(-) diff --git a/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs b/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs index 539d697e..583cb0c8 100644 --- a/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs +++ b/grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs @@ -1,48 +1,64 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Transformations.ExtendedSyntax.Optimising.DeadFunctionEliminationSpec where +import Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination (deadFunctionElimination) + +import Data.Either (fromRight) + import Test.Hspec -import Test.Hspec.PipelineExample -import Pipeline.Pipeline hiding (pipeline) -import Grin.TH + +import Test.ExtendedSyntax.Assertions +import Grin.ExtendedSyntax.TH +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.PrimOpsPrelude (withPrimPrelude) +import Grin.ExtendedSyntax.TypeCheck (inferTypeEnv) +import AbstractInterpretation.ExtendedSyntax.LiveVariableSpec (calcLiveness) runTests :: IO () runTests = hspec spec +dfe :: Exp -> Exp +dfe e = either error id $ + deadFunctionElimination (calcLiveness e) (inferTypeEnv e) e + spec :: Spec spec = do describe "Dead Function Elimination" $ do - let deadFunctionEliminationPipeline = - [ T DeadFunctionElimination - ] - it "app_side_effect_1" $ do let before = [prog| grinMain = - p0 <- store (CInt 0) + k0 <- pure 0 + n0 <- pure (CInt k0) + p0 <- store n0 y0 <- f p0 y1 <- fetch p0 pure y1 f p = - update p (CInt 1) + k1 <- pure 1 + n1 <- pure (CInt k1) + _1 <- update p n1 pure 0 |] let after = [prog| grinMain = - p0 <- store (CInt 0) + k0 <- pure 0 + n0 <- pure (CInt k0) + p0 <- store n0 y0 <- f p0 y1 <- fetch p0 pure y1 f p = - update p (CInt 1) + k1 <- pure 1 + n1 <- pure (CInt k1) + _1 <- update p n1 pure 0 |] - pipelineSrc before after deadFunctionEliminationPipeline + dfe before `sameAs` after it "mutually_recursive" $ do let before = [prog| @@ -54,30 +70,35 @@ spec = do let after = [prog| grinMain = pure 0 |] - pipelineSrc before after deadFunctionEliminationPipeline + dfe before `sameAs` after it "replace_node" $ do let before = [prog| grinMain = - n0 <- f 0 + k0 <- pure 0 + n0 <- f k0 pure 0 f x = - p <- store (CInt 5) + k1 <- pure 1 + n1 <- pure (CInt k1) + p <- store n1 pure (CNode p) |] let after = [prog| grinMain = + k0 <- pure 0 n0 <- pure (#undefined :: {CNode[#ptr]}) pure 0 |] - pipelineSrc before after deadFunctionEliminationPipeline + dfe before `sameAs` after it "replace_simple_type" $ do let before = [prog| grinMain = - y0 <- f 0 + k0 <- pure 0 + y0 <- f k0 pure 0 f x = pure x @@ -85,10 +106,11 @@ spec = do let after = [prog| grinMain = + k0 <- pure 0 y0 <- pure (#undefined :: T_Int64) pure 0 |] - pipelineSrc before after deadFunctionEliminationPipeline + dfe before `sameAs` after it "simple" $ do let before = [prog| @@ -100,24 +122,26 @@ spec = do let after = [prog| grinMain = pure 0 |] - pipelineSrc before after deadFunctionEliminationPipeline + dfe before `sameAs` after it "true_side_effect_min" $ do - let before = [prog| + let before = withPrimPrelude [prog| grinMain = result_main <- Main.main1 $ pure () Main.main1 = - _prim_int_print $ 1 + k0 <- pure 0 + _prim_int_print $ k0 |] - let after = [prog| + let after = withPrimPrelude [prog| grinMain = result_main <- Main.main1 $ pure () Main.main1 = - _prim_int_print $ 1 + k0 <- pure 0 + _prim_int_print $ k0 |] - pipelineSrc before after deadFunctionEliminationPipeline + dfe before `sameAs` after