git.iko.soy/elk
on 966edcd help sign in
elk/src/Optimize/Case.hs
175 lines 4.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Optimize.Case
3 ( optimize
4 )
5 where
8import Control.Arrow (second)
9import qualified Data.Map as Map
10import Data.Map ((!))
11import qualified Data.Maybe as Maybe
13import qualified AST.Canonical as Can
14import qualified AST.Optimized as Opt
15import qualified Elm.Name as N
16import qualified Optimize.DecisionTree as DT
20-- OPTIMIZE A CASE EXPRESSION
23optimize :: N.Name -> [(Can.Pattern, Opt.Expr)] -> Opt.Expr
24optimize exprName optBranches =
25 let
26 (patterns, indexedBranches) =
27 unzip (zipWith indexify [0..] optBranches)
28 in
29 treeToExpr exprName (DT.compile patterns) indexedBranches
32indexify :: Int -> (a,b) -> ((a,Int), (Int,b))
33indexify index (pattern, branch) =
34 ( (pattern, index)
35 , (index, branch)
36 )
40-- CONVERT A TREE TO AN EXPRESSION
43treeToExpr :: N.Name -> DT.DecisionTree -> [(Int, Opt.Expr)] -> Opt.Expr
44treeToExpr name decisionTree allJumps =
45 let
46 decider =
47 treeToDecider decisionTree
49 targetCounts =
50 countTargets decider
52 (choices, maybeJumps) =
53 unzip (map (createChoices targetCounts) allJumps)
54 in
55 Opt.Case
56 name
57 (insertChoices (Map.fromList choices) decider)
58 (Maybe.catMaybes maybeJumps)
62-- TREE TO DECIDER
63--
64-- Decision trees may have some redundancies, so we convert them to a Decider
65-- which has special constructs to avoid code duplication when possible.
68treeToDecider :: DT.DecisionTree -> Opt.Decider Int
69treeToDecider tree =
70 case tree of
71 DT.Match target ->
72 Opt.Leaf target
74 -- zero options
75 DT.Decision _ [] Nothing ->
76 error "compiler bug, somehow created an empty decision tree"
78 -- one option
79 DT.Decision _ [(_, subTree)] Nothing ->
80 treeToDecider subTree
82 DT.Decision _ [] (Just subTree) ->
83 treeToDecider subTree
85 -- two options
86 DT.Decision path [(test, successTree)] (Just failureTree) ->
87 toChain path test successTree failureTree
89 DT.Decision path [(test, successTree), (_, failureTree)] Nothing ->
90 toChain path test successTree failureTree
92 -- many options
93 DT.Decision path edges Nothing ->
94 let
95 (necessaryTests, fallback) =
96 (init edges, snd (last edges))
97 in
98 Opt.FanOut
99 path
100 (map (second treeToDecider) necessaryTests)
101 (treeToDecider fallback)
103 DT.Decision path edges (Just fallback) ->
104 Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback)
107toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int
108toChain path test successTree failureTree =
109 let
110 failure =
111 treeToDecider failureTree
112 in
113 case treeToDecider successTree of
114 Opt.Chain testChain success subFailure | failure == subFailure ->
115 Opt.Chain ((path, test) : testChain) success failure
117 success ->
118 Opt.Chain [(path, test)] success failure
122-- INSERT CHOICES
123--
124-- If a target appears exactly once in a Decider, the corresponding expression
125-- can be inlined. Whether things are inlined or jumps is called a "choice".
128countTargets :: Opt.Decider Int -> Map.Map Int Int
129countTargets decisionTree =
130 case decisionTree of
131 Opt.Leaf target ->
132 Map.singleton target 1
134 Opt.Chain _ success failure ->
135 Map.unionWith (+) (countTargets success) (countTargets failure)
137 Opt.FanOut _ tests fallback ->
138 Map.unionsWith (+) (map countTargets (fallback : map snd tests))
141createChoices
142 :: Map.Map Int Int
143 -> (Int, Opt.Expr)
144 -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) )
145createChoices targetCounts (target, branch) =
146 if targetCounts ! target == 1 then
147 ( (target, Opt.Inline branch)
148 , Nothing
149 )
151 else
152 ( (target, Opt.Jump target)
153 , Just (target, branch)
154 )
157insertChoices
158 :: Map.Map Int Opt.Choice
159 -> Opt.Decider Int
160 -> Opt.Decider Opt.Choice
161insertChoices choiceDict decider =
162 let
163 go =
164 insertChoices choiceDict
165 in
166 case decider of
167 Opt.Leaf target ->
168 Opt.Leaf (choiceDict ! target)
170 Opt.Chain testChain success failure ->
171 Opt.Chain testChain (go success) (go failure)
173 Opt.FanOut path tests fallback ->
174 Opt.FanOut path (map (second go) tests) (go fallback)