@@ -8,88 +8,166 @@ import qualified Data.Maybe as Maybe
88
99import qualified AST.Expression.Optimized as Opt
1010import qualified AST.Pattern as P
11−import Elm.Utils ((|>))
1211import qualified Optimize.Environment as Env
1312import qualified Optimize.Patterns.DecisionTree as DT
1413import qualified Reporting.Annotation as A
1514import qualified Reporting.Region as R
1615
1716
17+
18+-- OPTIMIZE A CASE EXPRESSION
19+
20+
1821optimize
1922 :: DT.VariantDict
2023 -> R.Region
21− -> Opt.Expr
24+ -> String
2225 -> [(P.CanonicalPattern, Opt.Expr)]
2326 -> Env.Optimizer Opt.Expr
24−optimize variantDict region optExpr optBranches =
25− let
26− indexify index (pattern, branch) =
27− ( (pattern, index)
28− , (index, branch)
29− )
30− in
31− do crashBranches <-
32− case last optBranches of
33− (A.A ann P.Anything, Opt.Call (Opt.Crash _ _) [arg]) ->
34− do name <- Env.freshName
35− let newPattern = A.A ann (P.Var name)
36− let newCall = Opt.Call (Opt.Crash region (Just name)) [arg]
37− return (init optBranches ++ [(newPattern, newCall)])
38−
39− _ ->
40− return optBranches
41−
42− let (patterns, indexedBranches) =
43− unzip (zipWith indexify [0..] crashBranches)
44−
45− let decisionTree =
46− DT.compile variantDict patterns
47−
48− tempName <- Env.freshName
49−
50− return $
51− Opt.Let
52− [ Opt.Def Opt.dummyFacts tempName optExpr ]
53− (inlinedCase tempName decisionTree indexedBranches)
54−
55−
56−inlinedCase
57− :: String
58− -> DT.DecisionTree Int
59− -> [(Int, Opt.Expr)]
60− -> Opt.Expr
61−inlinedCase name decisionTree jumpTargets =
27+optimize variantDict region exprName optBranches =
28+ do crashBranches <-
29+ mapM (tagCrashBranches region) optBranches
30+
31+ let (patterns, indexedBranches) =
32+ unzip (zipWith indexify [0..] crashBranches)
33+
34+ let decisionTree =
35+ DT.compile variantDict patterns
36+
37+ return (treeToExpr exprName decisionTree indexedBranches)
38+
39+
40+tagCrashBranches
41+ :: R.Region
42+ -> (P.CanonicalPattern, Opt.Expr)
43+ -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
44+tagCrashBranches region branch@(pattern@(A.A pr _), expr) =
45+ case expr of
46+ Opt.Call (Opt.Crash _ _) [arg] ->
47+ do name <- Env.freshName
48+ return
49+ ( A.A pr (P.Alias name pattern)
50+ , Opt.Call (Opt.Crash region (Just name)) [arg]
51+ )
52+
53+ _ ->
54+ return branch
55+
56+
57+indexify :: Int -> (a,b) -> ((a,Int), (Int,b))
58+indexify index (pattern, branch) =
59+ ( (pattern, index)
60+ , (index, branch)
61+ )
62+
63+
64+
65+-- CONVERT A TREE TO AN EXPRESSION
66+
67+
68+treeToExpr :: String -> DT.DecisionTree -> [(Int, Opt.Expr)] -> Opt.Expr
69+treeToExpr name decisionTree allJumps =
6270 let
71+ decider =
72+ treeToDecider decisionTree
73+
6374 targetCounts =
64− countTargets decisionTree
75+ countTargets decider
6576
66− (decisions, sharedBranches) =
67− unzip (map (toDecisions targetCounts) jumpTargets)
77+ (choices, maybeJumps) =
78+ unzip (map (createChoices targetCounts) allJumps)
6879 in
6980 Opt.Case
7081 name
71− (inlineDecisions (Map.fromList decisions) decisionTree)
72− (Maybe.catMaybes sharedBranches)
82+ (insertChoices (Map.fromList choices) decider)
83+ (Maybe.catMaybes maybeJumps)
7384
7485
75−countTargets :: DT.DecisionTree Int -> Map.Map Int Int
76−countTargets decisionTree =
77− case decisionTree of
78− DT.Decision _ edges fallback ->
79− map snd edges
80− |> maybe id (:) fallback
81− |> map countTargets
82− |> Map.unionsWith (+)
8386
87+-- TREE TO DECIDER
88+--
89+-- Decision trees may have some redundancies, so we convert them to a Decider
90+-- which has special constructs to avoid code duplication when possible.
91+
92+
93+treeToDecider :: DT.DecisionTree -> Opt.Decider Int
94+treeToDecider tree =
95+ case tree of
8496 DT.Match target ->
97+ Opt.Leaf target
98+
99+ -- zero options
100+ DT.Decision _ [] Nothing ->
101+ error "compiler bug, somehow created an empty decision tree"
102+
103+ -- one option
104+ DT.Decision _ [(_, subTree)] Nothing ->
105+ treeToDecider subTree
106+
107+ DT.Decision _ [] (Just subTree) ->
108+ treeToDecider subTree
109+
110+ -- two options
111+ DT.Decision path [(test, successTree)] (Just failureTree) ->
112+ toChain path test successTree failureTree
113+
114+ DT.Decision path [(test, successTree), (_, failureTree)] Nothing ->
115+ toChain path test successTree failureTree
116+
117+ -- many options
118+ DT.Decision path edges Nothing ->
119+ let
120+ (necessaryTests, fallback) =
121+ (init edges, snd (last edges))
122+ in
123+ Opt.FanOut
124+ path
125+ (map (second treeToDecider) necessaryTests)
126+ (treeToDecider fallback)
127+
128+ DT.Decision path edges (Just fallback) ->
129+ Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback)
130+
131+
132+toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int
133+toChain path test successTree failureTree =
134+ let
135+ failure =
136+ treeToDecider failureTree
137+ in
138+ case treeToDecider successTree of
139+ Opt.Chain testChain success subFailure | failure == subFailure ->
140+ Opt.Chain ((path, test) : testChain) success failure
141+
142+ success ->
143+ Opt.Chain [(path, test)] success failure
144+
145+
146+
147+-- INSERT CHOICES
148+--
149+-- If a target appears exactly once in a Decider, the corresponding expression
150+-- can be inlined. Whether things are inlined or jumps is called a "choice".
151+
152+
153+countTargets :: Opt.Decider Int -> Map.Map Int Int
154+countTargets decisionTree =
155+ case decisionTree of
156+ Opt.Leaf target ->
85157 Map.singleton target 1
86158
159+ Opt.Chain _ success failure ->
160+ Map.unionWith (+) (countTargets success) (countTargets failure)
87161
88−toDecisions
162+ Opt.FanOut _ tests fallback ->
163+ Map.unionsWith (+) (map countTargets (fallback : map snd tests))
164+
165+
166+createChoices
89167 :: Map.Map Int Int
90168 -> (Int, Opt.Expr)
91− -> ( (Int, Opt.Decision), Maybe (Int, Opt.Expr) )
92−toDecisions targetCounts (target, branch) =
169+ -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) )
170+createChoices targetCounts (target, branch) =
93171 if targetCounts ! target == 1 then
94172 ( (target, Opt.Inline branch)
95173 , Nothing
@@ -101,18 +179,25 @@ toDecisions targetCounts (target, branch) =
101179 )
102180
103181
104−inlineDecisions
105− :: Map.Map Int Opt.Decision
106− -> DT.DecisionTree Int
107− -> DT.DecisionTree Opt.Decision
108−inlineDecisions jumpDict decisionTree =
182+insertChoices
183+ :: Map.Map Int Opt.Choice
184+ -> Opt.Decider Int
185+ -> Opt.Decider Opt.Choice
186+insertChoices choiceDict decider =
109187 let
110188 go =
111− inlineDecisions jumpDict
189+ insertChoices choiceDict
112190 in
113− case decisionTree of
114− DT.Decision test edges fallback ->
115− DT.Decision test (map (second go) edges) (fmap go fallback)
191+ case decider of
192+ Opt.Leaf target ->
193+ Opt.Leaf (choiceDict ! target)
194+
195+ Opt.Chain testChain success failure ->
196+ Opt.Chain testChain (go success) (go failure)
197+
198+ Opt.FanOut path tests fallback ->
199+ Opt.FanOut path (map (second go) tests) (go fallback)
200+
201+
202+
116203
117− DT.Match target ->
118− DT.Match (jumpDict ! target)