Skip to content

Commit 449910f

Browse files
AnabraAnabra
authored
Merge pull request #72 from grin-compiler/32-trf-copy-propagation-2
Extended syntax: copy propagation
2 parents d307058 + ef24839 commit 449910f

File tree

5 files changed

+302
-4
lines changed

5 files changed

+302
-4
lines changed

‎grin/grin.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -146,6 +146,7 @@ library
146146
Transformations.ExtendedSyntax.GenerateEval
147147
Transformations.ExtendedSyntax.MangleNames
148148
Transformations.ExtendedSyntax.StaticSingleAssignment
149+
Transformations.ExtendedSyntax.Optimising.CopyPropagation
149150
Transformations.ExtendedSyntax.Optimising.CSE
150151
Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination
151152
Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination
@@ -300,6 +301,7 @@ test-suite grin-test
300301
Transformations.ExtendedSyntax.ConversionSpec
301302
Transformations.ExtendedSyntax.MangleNamesSpec
302303
Transformations.ExtendedSyntax.StaticSingleAssignmentSpec
304+
Transformations.ExtendedSyntax.Optimising.CopyPropagationSpec
303305
Transformations.ExtendedSyntax.Optimising.CSESpec
304306
Transformations.ExtendedSyntax.Optimising.EvaluatedCaseEliminationSpec
305307
Transformations.ExtendedSyntax.Optimising.TrivialCaseEliminationSpec

‎grin/src/Transformations/ExtendedSyntax/Optimising/CopyPropagation.hs‎

Lines changed: 115 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,115 @@
1+
{-# LANGUAGE LambdaCase, TupleSections, ViewPatterns #-}
2+
module Transformations.ExtendedSyntax.Optimising.CopyPropagation where
3+
4+
import Control.Monad.State.Strict
5+
6+
import Data.Map.Strict (Map)
7+
import qualified Data.Map.Strict as Map
8+
import Data.Functor.Foldable as Foldable
9+
10+
import Text.Printf
11+
import Lens.Micro.Extra
12+
13+
import Grin.ExtendedSyntax.Grin
14+
import Transformations.ExtendedSyntax.Util
15+
16+
{-
17+
NOTE:
18+
Do not propagate literal values because literals are not used for optimisations. (GRIN is not a supercompiler)
19+
Only propagates variables. It does not cause performance penalty, LLVM will optimise the code further.
20+
21+
CopyPropagation neither does replace literal values with variables (storing the same value),
22+
nor does it eliminate as-patterns matching a variables against a literal value (which is the same as the value stored by the variable).
23+
24+
TODO:
25+
Is the as-pattern elimination handled by LLVM?
26+
We will figure this out after implementing the LLVM codegen for as-patterns.
27+
28+
NOTE:
29+
Anamorphisms don't let us to "skip" bindings. We circumvent this issue by replacing the binding with a block.
30+
This will essentially skip the bind, since SBlockF is simply projected into SBlock. These extra (possibly nested)
31+
blocks will be removed in the cata part of the hylo.
32+
-}
33+
34+
-- (k,v) ~ the variable k has the original value v
35+
type OriginalValues = Map Name Val
36+
-- (k,v) ~ the variable k aliases to (is a copy of) v
37+
type Aliases = Map Name Name
38+
39+
type Env = (OriginalValues, Aliases)
40+
41+
copyPropagation :: Exp -> Exp
42+
copyPropagation = flip evalState mempty . hyloM rmBlocks builder where
43+
44+
builder :: Exp -> State Env (ExpF Exp)
45+
builder exp = do
46+
(origVals, aliases) <- get
47+
-- This substitutes all the variables on this level with their original aliases
48+
let exp' = substVarRefExp aliases $ exp
49+
50+
case exp' of
51+
-- left unit law
52+
EBind (SReturn (Var valVar)) (VarPat patVar) rightExp
53+
| origVar <- getAlias valVar aliases -> do
54+
let aliases' = Map.insert patVar origVar aliases
55+
newEnv = (origVals, aliases')
56+
put newEnv
57+
pure $ SBlockF rightExp
58+
59+
-- add the lhs value as an original value
60+
EBind (SReturn val) bpat@(VarPat patVar) rightExp
61+
| isn't _Lit val
62+
, valWithOrigVars <- substNamesVal aliases val -> do
63+
let origVals' = Map.insert patVar valWithOrigVars origVals
64+
newEnv = (origVals', aliases)
65+
put newEnv
66+
pure $ project $ EBind (SReturn valWithOrigVars) bpat rightExp
67+
68+
-- left unit law + eliminate redundant rebinds
69+
EBind (SReturn (Var valVar)) (AsPat patVar asPat) rightExp
70+
| origVar <- getAlias valVar aliases
71+
, origVal <- getOrigVal origVar origVals
72+
, ConstTagNode patTag patArgs <- asPat
73+
, ConstTagNode valTag valArgs <- origVal
74+
, patTag == valTag -> do
75+
let aliases' = aliases <> (Map.fromList $ zip (patVar:patArgs) (origVar:valArgs))
76+
newEnv = (origVals, aliases')
77+
put newEnv
78+
pure $ SBlockF rightExp
79+
80+
-- add the lhs value as an original value
81+
-- and eliminate redudant rebinds
82+
EBind (SReturn val) (AsPat patVar asPat) rightExp
83+
| isn't _Lit val
84+
, valWithOrigVars <- substNamesVal aliases val
85+
, ConstTagNode patTag patArgs <- asPat
86+
, ConstTagNode valTag valArgs <- valWithOrigVars
87+
, patTag == valTag -> do
88+
let origVals' = Map.insert patVar valWithOrigVars origVals
89+
aliases' = aliases <> (Map.fromList $ zip patArgs valArgs)
90+
newEnv = (origVals', aliases')
91+
put newEnv
92+
pure $ project $ EBind (SReturn val) (VarPat patVar) rightExp
93+
94+
-- simplify as-pattern matching against the same basic value it binds
95+
EBind (SReturn retVal) (AsPat var patVal) rightExp
96+
| isBasicValue retVal
97+
, retVal == patVal -> do
98+
pure $ project $ EBind (SReturn retVal) (VarPat var) rightExp
99+
100+
_ -> pure $ project exp'
101+
102+
-- NOTE: This cleans up the left-over produced by the above transformation.
103+
-- It removes nested blocks, and blocks appearing on the right-hand side of a
104+
-- binding. These are always safe to remove.
105+
rmBlocks :: ExpF Exp -> State Env Exp
106+
rmBlocks = \case
107+
EBindF lhs bpat (SBlock rhs) -> pure $ EBind lhs bpat rhs
108+
SBlockF exp@SBlock{} -> pure $ exp
109+
exp -> pure $ embed exp
110+
111+
getAlias :: Name -> Aliases -> Name
112+
getAlias var aliases = Map.findWithDefault var var aliases
113+
114+
getOrigVal :: Name -> OriginalValues -> Val
115+
getOrigVal var origVals = Map.findWithDefault (Var var) var origVals

‎grin/src/Transformations/ExtendedSyntax/Util.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -63,6 +63,7 @@ mapNamesCPat f = \case
6363
NodePat tag args -> NodePat tag (map f args)
6464
cpat -> cpat
6565

66+
-- apply a function to all @Name@s in a @Val@
6667
mapNamesVal :: (Name -> Name) -> Val -> Val
6768
mapNamesVal f = \case
6869
ConstTagNode tag args -> ConstTagNode tag (map f args)
@@ -106,19 +107,19 @@ mapNameUseExp f = \case
106107
subst :: Ord a => Map a a -> a -> a
107108
subst env x = Map.findWithDefault x x env
108109

109-
-- variable reference substitution (non recursive)
110+
-- substitute all @Names@s in an @Exp@ (non-recursive)
110111
substVarRefExp :: Map Name Name -> Exp -> Exp
111112
substVarRefExp env = mapNameUseExp (subst env)
112113

113-
-- val name substitution (non recursive)
114+
-- substitute all @Names@s in a @Val@ (non-recursive)
114115
substNamesVal :: Map Name Name -> Val -> Val
115116
substNamesVal env = mapNamesVal (subst env)
116117

117-
-- val name substitution (non recursive)
118+
-- specialized version of @subst@ to @Val@s (non-recursive)
118119
substValsVal :: Map Val Val -> Val -> Val
119120
substValsVal env = subst env
120121

121-
-- val substitution (non recursive)
122+
-- substitute all @Val@s in an @Exp@ (non-recursive)
122123
substVals :: Map Val Val -> Exp -> Exp
123124
substVals env = mapValsExp (subst env)
124125

‎grin/test/Transformations/ExtendedSyntax/Optimising/CopyPropagationSpec.hs‎

Lines changed: 167 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,167 @@
1+
{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}
2+
module Transformations.ExtendedSyntax.Optimising.CopyPropagationSpec where
3+
4+
import Transformations.ExtendedSyntax.Optimising.CopyPropagation
5+
6+
import Test.Hspec
7+
8+
import Grin.ExtendedSyntax.TH
9+
import Test.ExtendedSyntax.New.Test hiding (newVar)
10+
import Test.ExtendedSyntax.Assertions
11+
12+
13+
runTests :: IO ()
14+
runTests = hspec spec
15+
16+
17+
spec :: Spec
18+
spec = do
19+
testExprContextE $ \ctx -> do
20+
21+
it "left unit law" $ do
22+
let before = [expr|
23+
a1 <- pure 1
24+
a2 <- pure a1
25+
a3 <- pure a2
26+
pure a3
27+
|]
28+
let after = [expr|
29+
a1 <- pure 1
30+
pure a1
31+
|]
32+
copyPropagation (ctx before) `sameAs` (ctx after)
33+
34+
it "simple value" $ do
35+
let before = [expr|
36+
a1 <- pure 1
37+
a2 <- pure a1
38+
a3 <- pure a2
39+
case a2 of
40+
#default @ alt1 -> pure a3
41+
|]
42+
let after = [expr|
43+
a1 <- pure 1
44+
case a1 of
45+
#default @ alt1 -> pure a1
46+
|]
47+
copyPropagation (ctx before) `sameAs` (ctx after)
48+
49+
it "does not replace literal values" $ do
50+
let before = [expr|
51+
a1 <- pure 1
52+
a2 <- pure 1
53+
pure a2
54+
|]
55+
let after = [expr|
56+
a1 <- pure 1
57+
a2 <- pure 1
58+
pure a2
59+
|]
60+
copyPropagation (ctx before) `sameAs` (ctx after)
61+
62+
it "does not propagate literal values" $ do
63+
let before = [expr|
64+
a1 <- pure 1
65+
a2 <- pure a1
66+
0 @ _1 <- pure a2
67+
1 @ _2 <- pure a2
68+
pure a2
69+
|]
70+
let after = [expr|
71+
a1 <- pure 1
72+
0 @ _1 <- pure a1
73+
1 @ _2 <- pure a1
74+
pure a1
75+
|]
76+
copyPropagation (ctx before) `sameAs` (ctx after)
77+
78+
it "node value - node pattern" $ do
79+
let before = [expr|
80+
a1 <- pure 1
81+
b1 <- pure 0
82+
n1 <- pure (CNode a1 b1)
83+
n2 <- pure n1
84+
(CNode a2 b2) @ _1 <- pure n2
85+
b3 <- pure b2
86+
(CNode a3 b4) @ _2 <- pure (CNode a2 b3)
87+
pure (CNode a3 b4)
88+
|]
89+
let after = [expr|
90+
a1 <- pure 1
91+
b1 <- pure 0
92+
n1 <- pure (CNode a1 b1)
93+
_2 <- pure (CNode a1 b1)
94+
pure (CNode a1 b1)
95+
|]
96+
copyPropagation (ctx before) `sameAs` (ctx after)
97+
98+
it "node value - var pattern" $ do
99+
let before = [expr|
100+
a1 <- pure 1
101+
b1 <- pure 0
102+
n1 <- pure (CNode a1 b1)
103+
a2 <- pure a1
104+
n2 <- pure (CNode a2 b1)
105+
case n2 of
106+
#default @ alt1 -> pure n2
107+
|]
108+
let after = [expr|
109+
a1 <- pure 1
110+
b1 <- pure 0
111+
n1 <- pure (CNode a1 b1)
112+
n2 <- pure (CNode a1 b1)
113+
case n2 of
114+
#default @ alt1 -> pure n2
115+
|]
116+
copyPropagation (ctx before) `sameAs` (ctx after)
117+
118+
it "node value - substitution" $ do
119+
let before = [expr|
120+
c1 <- pure 0
121+
n1 <- pure (CInt c1)
122+
n2 <- pure n1
123+
v1 <- pure n2
124+
(CInt a1) @ v2 <- pure v1
125+
foo a1 v1
126+
|]
127+
let after = [expr|
128+
c1 <- pure 0
129+
n1 <- pure (CInt c1)
130+
foo c1 n1
131+
|]
132+
copyPropagation (ctx before) `sameAs` (ctx after)
133+
134+
it "node pattern mismatch" $ do
135+
let before = [expr|
136+
c1 <- pure 1
137+
n1 <- pure (CPair c1 c1)
138+
(CNode v1 v2) @ _1 <- pure n1
139+
(CPair v3 v4) @ _2 <- pure n1
140+
pure ()
141+
|]
142+
let after = [expr|
143+
c1 <- pure 1
144+
n1 <- pure (CPair c1 c1)
145+
(CNode v1 v2) @ _1 <- pure n1
146+
pure ()
147+
|]
148+
copyPropagation (ctx before) `sameAs` (ctx after)
149+
150+
it "bugfix - node pattern - var (infinite loop)" $ do
151+
let before = [expr|
152+
c1 <- pure 1
153+
n1 <- pure (CNode c1 c1)
154+
p1 <- store n1
155+
v1 <- fetch p1
156+
(CNode p2 p3) @ _1 <- pure v1
157+
pure ()
158+
|]
159+
let after = [expr|
160+
c1 <- pure 1
161+
n1 <- pure (CNode c1 c1)
162+
p1 <- store n1
163+
v1 <- fetch p1
164+
(CNode p2 p3) @ _1 <- pure v1
165+
pure ()
166+
|]
167+
copyPropagation (ctx before) `sameAs` (ctx after)

‎grin/test/Transformations/Optimising/CopyPropagationSpec.hs‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,19 @@ spec = do
4444
|]
4545
copyPropagation (ctx before) `sameAs` (ctx after)
4646

47+
it "does not propagate literal values" $ do
48+
let before = [expr|
49+
a1 <- pure 1
50+
a2 <- pure 1
51+
pure a2
52+
|]
53+
let after = [expr|
54+
a1 <- pure 1
55+
a2 <- pure 1
56+
pure a2
57+
|]
58+
copyPropagation (ctx before) `sameAs` (ctx after)
59+
4760
it "node value - node pattern" $ do
4861
let before = [expr|
4962
a1 <- pure 1

0 commit comments

Comments
 (0)