Merge branch '32-extended-syntax' into 32-trf-cse-2

Author: Anabra

grin/grin.cabal

@@ -147,6 +147,8 @@ library
     Transformations.ExtendedSyntax.MangleNames
     Transformations.ExtendedSyntax.StaticSingleAssignment
     Transformations.ExtendedSyntax.Optimising.CSE
+    Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination
+    Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination
 
     Transformations.BindNormalisation
     Transformations.CountVariableUse
@@ -299,6 +301,8 @@ test-suite grin-test
                      Transformations.ExtendedSyntax.MangleNamesSpec
                      Transformations.ExtendedSyntax.StaticSingleAssignmentSpec
                      Transformations.ExtendedSyntax.Optimising.CSESpec
+                     Transformations.ExtendedSyntax.Optimising.EvaluatedCaseEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.TrivialCaseEliminationSpec
 
                      Transformations.Simplifying.RegisterIntroductionSpec
                      Transformations.Simplifying.CaseSimplificationSpec

grin/src/Transformations/ExtendedSyntax/Optimising/EvaluatedCaseElimination.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE LambdaCase, TupleSections #-}
+module Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination where
+
+import Data.Functor.Foldable as Foldable
+import Grin.ExtendedSyntax.Grin
+
+evaluatedCaseElimination :: Exp -> Exp
+evaluatedCaseElimination = ana builder where
+  builder :: Exp -> ExpF Exp
+  builder = \case
+    ECase scrut alts | all (altBodyEQ $ SReturn (Var scrut)) alts -> SReturnF (Var scrut)
+    exp -> project exp
+
+  altBodyEQ :: Exp -> Alt -> Bool
+  altBodyEQ exp (Alt _cpat _altName body) = exp == body
+

grin/src/Transformations/ExtendedSyntax/Optimising/TrivialCaseElimination.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE LambdaCase, TupleSections #-}
+module Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination where
+
+import Data.Functor.Foldable as Foldable
+import Grin.ExtendedSyntax.Grin
+import Transformations.ExtendedSyntax.Util
+
+trivialCaseElimination :: Exp -> Exp
+trivialCaseElimination = ana builder where
+  builder :: Exp -> ExpF Exp
+  builder = \case
+    ECase scrut [Alt DefaultPat altName body] -> SBlockF $ EBind (SReturn (Var scrut)) (VarPat altName)           body
+    ECase scrut [Alt cpat       altName body] -> SBlockF $ EBind (SReturn (Var scrut)) (cPatToAsPat altName cpat) body
+    exp -> project exp

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

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}
+module Transformations.ExtendedSyntax.Optimising.EvaluatedCaseEliminationSpec where
+
+import Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination
+
+import Test.Hspec
+import Grin.ExtendedSyntax.TH
+import Test.ExtendedSyntax.New.Test hiding (newVar)
+import Test.ExtendedSyntax.Assertions
+
+
+runTests :: IO ()
+runTests = hspec spec
+
+spec :: Spec
+spec = do
+  testExprContextE $ \ctx -> do
+    it "Figure 4.22" $ do
+      let before = [expr|
+          case v of
+            (CLeft l)  @ alt1 -> pure v
+            (CRight r) @ alt2 -> pure v
+        |]
+      let after = [expr|
+          pure v
+        |]
+      evaluatedCaseElimination (ctx before) `sameAs` (ctx after)
+
+    it "default case" $ do
+      let before = [expr|
+          case v of
+            (CLeft l) @ alt1 -> pure v
+            #default  @ alt2 -> pure v
+        |]
+      let after = [expr|
+          pure v
+        |]
+      evaluatedCaseElimination (ctx before) `sameAs` (ctx after)

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

@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}
+module Transformations.ExtendedSyntax.Optimising.TrivialCaseEliminationSpec where
+
+import Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination
+
+import Test.Hspec
+import Grin.ExtendedSyntax.TH
+import Test.ExtendedSyntax.New.Test hiding (newVar)
+import Test.ExtendedSyntax.Assertions
+
+
+runTests :: IO ()
+runTests = hspec spec
+
+spec :: Spec
+spec = do
+  testExprContextE $ \ctx -> do
+    it "Figure 4.24" $ do
+      let before = [expr|
+          case v of
+            (Ffun a1 a2 a3) @ alt1 -> fun a1 a2 a3
+        |]
+      let after = [expr|
+          do
+            (Ffun a1 a2 a3) @ alt1 <- pure v
+            fun a1 a2 a3
+        |]
+      trivialCaseElimination (ctx before) `sameAs` (ctx after)
+
+    it "bypass" $ do
+      let before = [expr|
+          case v of
+            (Ffun1 a1 a2 a3) @ alt1 -> fun1 a1 a2 a3
+            #default         @ alt2 -> pure 2
+        |]
+      let after = [expr|
+          case v of
+            (Ffun1 a1 a2 a3) @ alt1 -> fun1 a1 a2 a3
+            #default         @ alt2 -> pure 2
+        |]
+      trivialCaseElimination (ctx before) `sameAs` (ctx after)
+
+    it "default alternative" $ do
+      let before = [expr|
+          case v of
+            #default @ alt1 -> pure 2
+        |]
+      let after = [expr|
+          do
+            alt1 <- pure v
+            pure 2
+        |]
+      trivialCaseElimination (ctx before) `sameAs` (ctx after)