@@ -8,117 +8,196 @@ 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 DT.Jump
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
63− substitutionDict =
64− gatherSubstitutions decisionTree
71+ decider =
72+ treeToDecider decisionTree
73+
74+ targetCounts =
75+ countTargets decider
6576
66− (jumps, sharedBranches) =
67− unzip (map (toJumps substitutionDict) jumpTargets)
77+ (choices, maybeJumps) =
78+ unzip (map (createChoices targetCounts) allJumps)
6879 in
6980 Opt.Case
7081 name
71− (inlineJumps (Map.fromList jumps) decisionTree)
72− (Maybe.catMaybes sharedBranches)
82+ (insertChoices (Map.fromList choices) decider)
83+ (Maybe.catMaybes maybeJumps)
84+
85+
86+
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
96+ DT.Match target ->
97+ Opt.Leaf target
7398
99+ -- zero options
100+ DT.Decision _ [] Nothing ->
101+ error "compiler bug, somehow created an empty decision tree"
74102
75−gatherSubstitutions
76− :: DT.DecisionTree DT.Jump
77− -> Map.Map Int [[(String, DT.Path)]]
78−gatherSubstitutions decisionTree =
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 =
79155 case decisionTree of
80− DT.Decision _ edges fallback ->
81− map snd edges
82− |> maybe id (:) fallback
83− |> map gatherSubstitutions
84− |> Map.unionsWith (++)
156+ Opt.Leaf target ->
157+ Map.singleton target 1
158+
159+ Opt.Chain _ success failure ->
160+ Map.unionWith (+) (countTargets success) (countTargets failure)
85161
86− DT.Match (DT.Jump target substitutions) ->
87− Map.singleton target [substitutions]
162+ Opt.FanOut _ tests fallback ->
163+ Map.unionsWith (+) (map countTargets (fallback : map snd tests))
88164
89165
90−toJumps
91− :: Map.Map Int [[(String, DT.Path)]]
166+createChoices
167+ :: Map.Map Int Int
92168 -> (Int, Opt.Expr)
93− -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )
94−toJumps substitutionDict (target, branch) =
95− case substitutionDict ! target of
96− [substitutions] ->
97− ( (target, Opt.Inline (Opt.Branch substitutions branch))
98− , Nothing
99− )
100−
101− substitutions : _ ->
102− ( (target, Opt.Jump target)
103− , Just (target, Opt.Branch substitutions branch)
104− )
105−
106− _ ->
107− error "it is not possible for there to be no substitutions"
108−
109−
110−inlineJumps
111− :: Map.Map Int Opt.Jump
112− -> DT.DecisionTree DT.Jump
113− -> DT.DecisionTree Opt.Jump
114−inlineJumps jumpDict decisionTree =
169+ -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) )
170+createChoices targetCounts (target, branch) =
171+ if targetCounts ! target == 1 then
172+ ( (target, Opt.Inline branch)
173+ , Nothing
174+ )
175+
176+ else
177+ ( (target, Opt.Jump target)
178+ , Just (target, branch)
179+ )
180+
181+
182+insertChoices
183+ :: Map.Map Int Opt.Choice
184+ -> Opt.Decider Int
185+ -> Opt.Decider Opt.Choice
186+insertChoices choiceDict decider =
115187 let
116188 go =
117− inlineJumps jumpDict
189+ insertChoices choiceDict
118190 in
119− case decisionTree of
120− DT.Decision test edges fallback ->
121− 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+
122203
123− DT.Match (DT.Jump target _) ->
124− DT.Match (jumpDict ! target)