Merge pull request #98 from grin-compiler/32-trf-dfe

Extended Syntax: dead function elimination

grin/grin.cabal

@@ -153,6 +153,7 @@ library
     Transformations.ExtendedSyntax.Optimising.ConstantPropagation
     Transformations.ExtendedSyntax.Optimising.CSE
     Transformations.ExtendedSyntax.Optimising.DeadDataElimination
+    Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination
     Transformations.ExtendedSyntax.Optimising.DeadParameterElimination
     Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination
     Transformations.ExtendedSyntax.Optimising.Inlining
@@ -320,6 +321,7 @@ test-suite grin-test
                      Transformations.ExtendedSyntax.Optimising.CopyPropagationSpec
                      Transformations.ExtendedSyntax.Optimising.CSESpec
                      Transformations.ExtendedSyntax.Optimising.DeadDataEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.DeadFunctionEliminationSpec
                      Transformations.ExtendedSyntax.Optimising.DeadParameterEliminationSpec
                      Transformations.ExtendedSyntax.Optimising.EvaluatedCaseEliminationSpec
                      Transformations.ExtendedSyntax.Optimising.InliningSpec

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.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
+
+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"

grin/test/Transformations/ExtendedSyntax/Optimising/DeadFunctionEliminationSpec.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+module Transformations.ExtendedSyntax.Optimising.DeadFunctionEliminationSpec where
+
+import Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination (deadFunctionElimination)
+
+import Data.Either (fromRight)
+
+import Test.Hspec
+
+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
+
+    it "app_side_effect_1" $ do
+      let before = [prog|
+            grinMain =
+              k0 <- pure 0
+              n0 <- pure (CInt k0)
+              p0 <- store n0
+              y0 <- f p0
+              y1 <- fetch p0
+              pure y1
+
+            f p =
+              k1 <- pure 1
+              n1 <- pure (CInt k1)
+              _1 <- update p n1
+              pure 0
+          |]
+
+      let after = [prog|
+            grinMain =
+              k0 <- pure 0
+              n0 <- pure (CInt k0)
+              p0 <- store n0
+              y0 <- f p0
+              y1 <- fetch p0
+              pure y1
+
+            f p =
+              k1 <- pure 1
+              n1 <- pure (CInt k1)
+              _1 <- update p n1
+              pure 0
+          |]
+      dfe before `sameAs` after
+
+    it "mutually_recursive" $ do
+      let before = [prog|
+            grinMain = pure 0
+            f x = g x
+            g y = f y
+          |]
+
+      let after = [prog|
+            grinMain = pure 0
+          |]
+      dfe before `sameAs` after
+
+    it "replace_node" $ do
+      let before = [prog|
+            grinMain =
+              k0 <- pure 0
+              n0 <- f k0
+              pure 0
+
+            f x =
+              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
+          |]
+      dfe before `sameAs` after
+
+    it "replace_simple_type" $ do
+      let before = [prog|
+            grinMain =
+              k0 <- pure 0
+              y0 <- f k0
+              pure 0
+
+            f x = pure x
+          |]
+
+      let after = [prog|
+            grinMain =
+              k0 <- pure 0
+              y0 <- pure (#undefined :: T_Int64)
+              pure 0
+          |]
+      dfe before `sameAs` after
+
+    it "simple" $ do
+      let before = [prog|
+            grinMain = pure 0
+
+            f x = pure x
+          |]
+
+      let after = [prog|
+            grinMain = pure 0
+          |]
+      dfe before `sameAs` after
+
+    it "true_side_effect_min" $ do
+      let before = withPrimPrelude [prog|
+            grinMain =
+              result_main <- Main.main1 $
+              pure ()
+
+            Main.main1 =
+              k0 <- pure 0
+              _prim_int_print $ k0
+          |]
+
+      let after = withPrimPrelude [prog|
+            grinMain =
+              result_main <- Main.main1 $
+              pure ()
+
+            Main.main1 =
+              k0 <- pure 0
+              _prim_int_print $ k0
+          |]
+      dfe before `sameAs` after