git.iko.soy/elk
on bc71d83 help sign in
elk/src/Optimize/Patterns.hs
203 lines 5.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Optimize.Patterns (optimize) where
4import Control.Arrow (second)
5import qualified Data.Map as Map
6import Data.Map ((!))
7import qualified Data.Maybe as Maybe
9import qualified AST.Expression.Optimized as Opt
10import qualified AST.Pattern as P
11import qualified Optimize.Environment as Env
12import qualified Optimize.Patterns.DecisionTree as DT
13import qualified Reporting.Annotation as A
14import qualified Reporting.Region as R
18-- OPTIMIZE A CASE EXPRESSION
21optimize
22 :: DT.VariantDict
23 -> R.Region
24 -> String
25 -> [(P.CanonicalPattern, Opt.Expr)]
26 -> Env.Optimizer Opt.Expr
27optimize variantDict region exprName optBranches =
28 do crashBranches <-
29 mapM (tagCrashBranches region) optBranches
31 let (patterns, indexedBranches) =
32 unzip (zipWith indexify [0..] crashBranches)
34 let decisionTree =
35 DT.compile variantDict patterns
37 return (treeToExpr exprName decisionTree indexedBranches)
40tagCrashBranches
41 :: R.Region
42 -> (P.CanonicalPattern, Opt.Expr)
43 -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
44tagCrashBranches 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 )
53 _ ->
54 return branch
57indexify :: Int -> (a,b) -> ((a,Int), (Int,b))
58indexify index (pattern, branch) =
59 ( (pattern, index)
60 , (index, branch)
61 )
65-- CONVERT A TREE TO AN EXPRESSION
68treeToExpr :: String -> DT.DecisionTree -> [(Int, Opt.Expr)] -> Opt.Expr
69treeToExpr name decisionTree allJumps =
70 let
71 decider =
72 treeToDecider decisionTree
74 targetCounts =
75 countTargets decider
77 (choices, maybeJumps) =
78 unzip (map (createChoices targetCounts) allJumps)
79 in
80 Opt.Case
81 name
82 (insertChoices (Map.fromList choices) decider)
83 (Maybe.catMaybes maybeJumps)
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.
93treeToDecider :: DT.DecisionTree -> Opt.Decider Int
94treeToDecider tree =
95 case tree of
96 DT.Match target ->
97 Opt.Leaf target
99 -- zero options
100 DT.Decision _ [] Nothing ->
101 error "compiler bug, somehow created an empty decision tree"
103 -- one option
104 DT.Decision _ [(_, subTree)] Nothing ->
105 treeToDecider subTree
107 DT.Decision _ [] (Just subTree) ->
108 treeToDecider subTree
110 -- two options
111 DT.Decision path [(test, successTree)] (Just failureTree) ->
112 toChain path test successTree failureTree
114 DT.Decision path [(test, successTree), (_, failureTree)] Nothing ->
115 toChain path test successTree failureTree
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)
128 DT.Decision path edges (Just fallback) ->
129 Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback)
132toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int
133toChain 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
142 success ->
143 Opt.Chain [(path, test)] success failure
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".
153countTargets :: Opt.Decider Int -> Map.Map Int Int
154countTargets decisionTree =
155 case decisionTree of
156 Opt.Leaf target ->
157 Map.singleton target 1
159 Opt.Chain _ success failure ->
160 Map.unionWith (+) (countTargets success) (countTargets failure)
162 Opt.FanOut _ tests fallback ->
163 Map.unionsWith (+) (map countTargets (fallback : map snd tests))
166createChoices
167 :: Map.Map Int Int
168 -> (Int, Opt.Expr)
169 -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) )
170createChoices targetCounts (target, branch) =
171 if targetCounts ! target == 1 then
172 ( (target, Opt.Inline branch)
173 , Nothing
174 )
176 else
177 ( (target, Opt.Jump target)
178 , Just (target, branch)
179 )
182insertChoices
183 :: Map.Map Int Opt.Choice
184 -> Opt.Decider Int
185 -> Opt.Decider Opt.Choice
186insertChoices choiceDict decider =
187 let
188 go =
189 insertChoices choiceDict
190 in
191 case decider of
192 Opt.Leaf target ->
193 Opt.Leaf (choiceDict ! target)
195 Opt.Chain testChain success failure ->
196 Opt.Chain testChain (go success) (go failure)
198 Opt.FanOut path tests fallback ->
199 Opt.FanOut path (map (second go) tests) (go fallback)