mirror of
https://github.com/grin-compiler/grin.git
synced 2024-09-11 15:37:54 +03:00
CaseCopyPropagation optimising transformation.
This commit is contained in:
Andor Penzes
parent
964eb80ebb
commit
4ae27c2a4c
@ -39,6 +39,8 @@ instance FromTag CPat where
|
||||
tag name a = TagPat $ Tag C name
|
||||
(@:) cname params = NodePat (Tag C cname) params
|
||||
|
||||
(@@:) fname params = NodePat (Tag F fname) params
|
||||
|
||||
instance FromTag Val where
|
||||
tag name a = ValTag $ Tag C name
|
||||
(@:) cname params = ConstTagNode (Tag C cname) (Var <$> params)
|
||||
|
||||
162
grin/src/Transformations/Optimising/CaseCopyPropagation.hs
Normal file
162
grin/src/Transformations/Optimising/CaseCopyPropagation.hs
Normal file
@ -0,0 +1,162 @@
|
||||
{-# LANGUAGE LambdaCase, EmptyCase, ViewPatterns #-}
|
||||
module Transformations.Optimising.CaseCopyPropagation where
|
||||
|
||||
import Control.Arrow
|
||||
import Grin
|
||||
import Data.Functor.Foldable
|
||||
import Control.Monad.Free
|
||||
import Control.Comonad.Cofree
|
||||
import Data.Monoid hiding (Alt)
|
||||
import Debug.Trace
|
||||
import Data.Maybe
|
||||
import Data.List (find)
|
||||
|
||||
|
||||
{-
|
||||
When implementing the transformation we need to, for each case expression:
|
||||
1. Examine the return sites of all the alternatives
|
||||
2. Decide if the transformation applies (all returns must be similar units)
|
||||
3. Possible transform all the return sites
|
||||
4. Continue transforming the code in each alternative
|
||||
|
||||
The transformation can eve be done in a single pass and linear time,
|
||||
using techniques for circular algorithms.
|
||||
[Bir84, Joh87a]
|
||||
|
||||
Bir 84: R S Bird. Using Circular Programs to Eliminate Multiple Traversals of Data. 1984
|
||||
Joh87a: T. Johnson. Attribute Grammars as a Functional Programming Paradigm. 1987
|
||||
-}
|
||||
|
||||
-- * Collection
|
||||
|
||||
type Step = ExpF ()
|
||||
type Path = [Step]
|
||||
|
||||
data Info = Info
|
||||
{ returns :: [(Path, Maybe Tag)]
|
||||
, cases :: [(Path, Tag)]
|
||||
}
|
||||
deriving Show
|
||||
|
||||
instance Monoid Info where
|
||||
mempty = Info [] []
|
||||
mappend (Info r1 c1) (Info r2 c2) = Info (r1 <> r2) (c1 <> c2)
|
||||
|
||||
toStep :: ExpF a -> Step
|
||||
toStep = fmap (const ())
|
||||
|
||||
isEmptyInfo :: Info -> Bool
|
||||
isEmptyInfo (Info returns cases) = null returns && null cases
|
||||
|
||||
addStep :: Step -> Info -> Info
|
||||
addStep s (Info returns cases) = Info
|
||||
(map (\(p, v) -> ((s:p), v)) returns)
|
||||
(map (\(p, v) -> ((s:p), v)) cases)
|
||||
|
||||
stepInside :: Step -> Info -> Info
|
||||
stepInside s (Info returns cases) = Info
|
||||
(map (first tail) $ filter (([s] ==) . take 1 . fst) returns)
|
||||
(map (first tail) $ filter (([s] ==) . take 1 . fst) cases)
|
||||
|
||||
zoom :: Int -> Info -> Info
|
||||
zoom n (Info returns cases) = Info (map (first (drop n)) returns) (map (first (drop n)) cases)
|
||||
|
||||
caseTagOnStep :: Step -> Info -> Maybe Tag
|
||||
caseTagOnStep s (Info returns cases) = fmap snd $ find (([s] ==) . fst) $ cases
|
||||
|
||||
caseFocusOnStep :: Step -> Info -> Bool
|
||||
caseFocusOnStep s i = isJust $ caseTagOnStep s i
|
||||
|
||||
|
||||
collectInfo :: Exp -> Info
|
||||
collectInfo = para convert where
|
||||
convert :: ExpF (Exp, Info) -> Info
|
||||
convert e = addStep (toStep e) $ case e of
|
||||
EBindF (SBlock _, se) _ (_, r) -> se <> r
|
||||
EBindF _ _ (EBind _ _ _, r) -> r
|
||||
EBindF _ _ (ECase _ _, r) -> r
|
||||
|
||||
EBindF _ _ (SReturn (ConstTagNode tag@(Tag _ _) [v]), _) -> mempty { returns = [(mempty, Just tag)] } -- Good node
|
||||
EBindF _ _ (SReturn _, _) -> mempty { returns = [(mempty, Nothing)] } -- Bad node
|
||||
|
||||
ProgramF (mconcat . map snd -> info) -> info
|
||||
DefF _ _ (_, info) -> info { returns = mempty }
|
||||
|
||||
ECaseF v ((mconcat . map snd) -> info) -> case info of
|
||||
Info returns cases -> case (allTheSame $ map snd returns) of
|
||||
Just (Just tag) -> Info mempty (([], tag):cases) -- The case is the same return values
|
||||
Nothing -> Info mempty cases
|
||||
|
||||
AltF pat (ei, info) -> info
|
||||
SBlockF (ei, info) -> info
|
||||
|
||||
_ -> mempty
|
||||
|
||||
-- * Build
|
||||
|
||||
data BuilderState
|
||||
= Build Exp Info Bool
|
||||
| Skip Int Exp Info Bool
|
||||
|
||||
caseCopyPropagation :: Exp -> Exp
|
||||
caseCopyPropagation e = apo builder (Build e info False) where
|
||||
|
||||
info = collectInfo e
|
||||
|
||||
builder :: BuilderState -> ExpF (Either Exp BuilderState)
|
||||
|
||||
-- Skip some expressions without transforming them.
|
||||
builder (Skip 0 e0 i r) = builder (Build e0 i r)
|
||||
builder (Skip n e0 i r) = fmap (Right . (\e1 -> (Skip (n-1) e1 i r))) $ project e0
|
||||
|
||||
-- Real transformation.
|
||||
builder (Build e i False) | isEmptyInfo i = fmap Left $ project e
|
||||
builder (Build e i rewrite) = case e of
|
||||
-- Just step in in the followings
|
||||
Program defs -> ProgramF (map stepIn defs)
|
||||
Def n args body -> DefF n args (stepIn body)
|
||||
SBlock body -> SBlockF $ stepIn body
|
||||
Alt cpat body -> AltF cpat (stepIn body)
|
||||
|
||||
-- Exp: Insert nodes, skips them in the recursion and continue the transformation on the Case node.
|
||||
EBind lhs@(SBlock cs@(ECase var@(Var n) alts)) pat rhs
|
||||
| caseFocusOnStep (toStepE cs) i1 ->
|
||||
EBindF
|
||||
(Right $ Skip 3
|
||||
(SBlock (EBind lhs newVar (SReturn (ConstTagNode (fromJust (caseTagOnStep (toStepE cs) i1)) [newVar]))))
|
||||
i1
|
||||
True)
|
||||
pat
|
||||
(stepIn rhs)
|
||||
| otherwise -> EBindF (stepInF lhs) pat (stepIn rhs)
|
||||
where
|
||||
i1 = zoom 2 i
|
||||
newVar = Var (n <> "'")
|
||||
|
||||
EBind lhs pat rhs | isSimpleExp lhs -> EBindF (Left lhs) pat (stepIn rhs)
|
||||
EBind lhs pat rhs -> EBindF (stepIn lhs) pat (stepIn rhs)
|
||||
|
||||
ECase val alts
|
||||
| caseFocusOnStep step i -> ECaseF val (map stepInT alts)
|
||||
| otherwise -> ECaseF val (map stepIn alts)
|
||||
|
||||
r@(SReturn (ConstTagNode (Tag _ _) [v]))
|
||||
| rewrite -> SReturnF v
|
||||
| otherwise -> Left <$> project r
|
||||
|
||||
-- Simple Exp
|
||||
rest -> Left <$> project rest
|
||||
where
|
||||
stepIn e0 = Right (Build e0 (stepInside step i) rewrite)
|
||||
stepInT e0 = Right (Build e0 (stepInside step i) True)
|
||||
stepInF e0 = Right (Build e0 (stepInside step i) False)
|
||||
step = toStepE e
|
||||
|
||||
toStepE :: Exp -> Step
|
||||
toStepE = toStep . project
|
||||
|
||||
-- * Utils
|
||||
|
||||
allTheSame :: (Eq a) => [a] -> Maybe a
|
||||
allTheSame [] = Nothing
|
||||
allTheSame (x:xs) = if any (/=x) xs then Nothing else Just x
|
||||
194
grin/test/Transformations/Optimising/CaseCopyPropagationSpec.hs
Normal file
194
grin/test/Transformations/Optimising/CaseCopyPropagationSpec.hs
Normal file
@ -0,0 +1,194 @@
|
||||
{-# LANGUAGE TypeApplications, OverloadedStrings #-}
|
||||
module Transformations.Optimising.CaseCopyPropagationSpec where
|
||||
|
||||
import Transformations.Optimising.CaseCopyPropagation
|
||||
|
||||
import Test.Hspec
|
||||
import Free
|
||||
import Grin
|
||||
import Test
|
||||
import Assertions
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
|
||||
it "Example from Figure 4.26" $ do
|
||||
before <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Int" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
after <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: (block $
|
||||
"v'" <=: (block $ switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Var "y'")
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Var "z'")
|
||||
, ("Int" @: ["x'"], unit @Var "x'")
|
||||
]) $
|
||||
unit @Val ("Int" @: ["v'"])) $
|
||||
unit @Var "m0"
|
||||
|
||||
caseCopyPropagation before `sameAs` after
|
||||
|
||||
it "One node has no Int tagged value" $ do
|
||||
before <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Float" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
after <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Float" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
caseCopyPropagation before `sameAs` after
|
||||
|
||||
it "Embedded good case" $ do
|
||||
before <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Int" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], "u1" <=: block (switch "v1"
|
||||
[ ("foo" @@: ["a1"], "y1'" <=: app "foo" ["a1"] $
|
||||
unit @Val ("Int" @: ["y1'"]))
|
||||
, ("bar" @@: ["b1"], "z1'" <=: app "bar" ["b1"] $
|
||||
unit @Val ("Int" @: ["z1'"]))
|
||||
, ("Int" @: ["x1'"], unit @Val ("Int" @: ["x1'"]))
|
||||
]) $
|
||||
unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
after <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: (block $
|
||||
"v'" <=: (block $ switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Var "y'")
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Var "z'")
|
||||
, ("Int" @: ["x'"], "u1" <=: (block $
|
||||
"v1'" <=: (block $ switch "v1"
|
||||
[ ("foo" @@: ["a1"], "y1'" <=: app "foo" ["a1"] $
|
||||
unit @Var "y1'")
|
||||
, ("bar" @@: ["b1"], "z1'" <=: app "bar" ["b1"] $
|
||||
unit @Var "z1'")
|
||||
, ("Int" @: ["x1'"], unit @Var "x1'")
|
||||
]) $
|
||||
unit @Val ("Int" @: ["v1'"])) $
|
||||
unit @Var "x'")
|
||||
]) $
|
||||
unit @Val ("Int" @: ["v'"])) $
|
||||
unit @Var "m0"
|
||||
|
||||
caseCopyPropagation before `sameAs` after
|
||||
|
||||
it "Embedded bad case" $ do
|
||||
before <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Int" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], "u1" <=: block (switch "v1"
|
||||
[ ("foo" @@: ["a1"], "y1'" <=: app "foo" ["a1"] $
|
||||
unit @Val ("Int" @: ["y1'"]))
|
||||
, ("bar" @@: ["b1"], "z1'" <=: app "bar" ["b1"] $
|
||||
unit @Val ("Float" @: ["z1'"]))
|
||||
, ("Int" @: ["x1'"], unit @Val ("Int" @: ["x1'"]))
|
||||
]) $
|
||||
unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
after <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: (block $
|
||||
"v'" <=: (block $ switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Var "y'")
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Var "z'")
|
||||
, ("Int" @: ["x'"], "u1" <=: block (switch "v1"
|
||||
[ ("foo" @@: ["a1"], "y1'" <=: app "foo" ["a1"] $
|
||||
unit @Val ("Int" @: ["y1'"]))
|
||||
, ("bar" @@: ["b1"], "z1'" <=: app "bar" ["b1"] $
|
||||
unit @Val ("Float" @: ["z1'"]))
|
||||
, ("Int" @: ["x1'"], unit @Val ("Int" @: ["x1'"]))
|
||||
]) $
|
||||
unit @Var "x'")
|
||||
]) $
|
||||
unit @Val ("Int" @: ["v'"])) $
|
||||
unit @Var "m0"
|
||||
|
||||
caseCopyPropagation before `sameAs` after
|
||||
|
||||
it "Leave the outher transform the inner" $ do
|
||||
before <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Float" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], "u1" <=: block (switch "v1"
|
||||
[ ("foo" @@: ["a1"], "y1'" <=: app "foo" ["a1"] $
|
||||
unit @Val ("Int" @: ["y1'"]))
|
||||
, ("bar" @@: ["b1"], "z1'" <=: app "bar" ["b1"] $
|
||||
unit @Val ("Int" @: ["z1'"]))
|
||||
, ("Int" @: ["x1'"], unit @Val ("Int" @: ["x1'"]))
|
||||
]) $
|
||||
unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
after <- buildExpM $
|
||||
"m0" <=: store @Int 3 $
|
||||
"u" <=: block (switch "v"
|
||||
[ ("foo" @@: ["a"], "y'" <=: app "foo" ["a"] $
|
||||
unit @Val ("Int" @: ["y'"]))
|
||||
, ("bar" @@: ["b"], "z'" <=: app "bar" ["b"] $
|
||||
unit @Val ("Float" @: ["z'"]))
|
||||
, ("Int" @: ["x'"], "u1" <=: (block $
|
||||
"v1'" <=: (block $ switch "v1"
|
||||
[ ("foo" @@: ["a1"], "y1'" <=: app "foo" ["a1"] $
|
||||
unit @Var "y1'")
|
||||
, ("bar" @@: ["b1"], "z1'" <=: app "bar" ["b1"] $
|
||||
unit @Var "z1'")
|
||||
, ("Int" @: ["x1'"], unit @Var "x1'")
|
||||
]) $
|
||||
unit @Val ("Int" @: ["v1'"])) $
|
||||
unit @Val ("Int" @: ["x'"]))
|
||||
]) $
|
||||
unit @Var "m0"
|
||||
|
||||
caseCopyPropagation before `sameAs` after
|
||||
|
||||
runTests :: IO ()
|
||||
runTests = hspec spec
|
||||
Loading…
Reference in New Issue
Block a user