git.iko.soy/elk
on 16c4b79 help sign in
elk/src/Optimize/Patterns.hs
125 lines 3.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Optimize.Patterns (optimize) where
4import Control.Applicative
5import Control.Arrow (second)
6import qualified Control.Monad as M
7import qualified Control.Monad.State as State
8import qualified Data.Map as Map
9import Data.Map ((!))
10import qualified Data.Maybe as Maybe
11import qualified Data.Traversable as T
13import qualified AST.Expression.Optimized as Opt
14import qualified AST.Module as Module
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Pattern as P
17import qualified AST.Variable as Var
18import Elm.Utils ((|>))
19import qualified Optimize.Environment as Env
20import qualified Optimize.Patterns.DecisionTree as DT
21import qualified Reporting.Annotation as A
22import qualified Reporting.Region as R
25optimize
26 :: R.Region
27 -> Opt.Expr
28 -> [(P.CanonicalPattern, Opt.Expr)]
29 -> Env.Optimizer Opt.Expr
30optimize region optExpr optBranches =
31 let
32 indexify index (pattern, branch) =
33 ( (pattern, index)
34 , (index, branch)
35 )
36 in
37 do crashBranches <-
38 case last optBranches of
39 (A.A ann P.Anything, Opt.Call (Opt.Crash _ _) [arg]) ->
40 do name <- Env.freshName
41 let newPattern = A.A ann (P.Var name)
42 let newCall = Opt.Call (Opt.Crash region (Just name)) [arg]
43 return (init optBranches ++ [(newPattern, newCall)])
45 _ ->
46 return optBranches
48 let (patterns, indexedBranches) =
49 unzip (zipWith indexify [0..] crashBranches)
51 let decisionTree =
52 DT.compile (error "need a VariantDict") patterns
54 return (inlinedCase optExpr decisionTree indexedBranches)
57inlinedCase
58 :: Opt.Expr
59 -> DT.DecisionTree DT.Jump
60 -> [(Int, Opt.Expr)]
61 -> Opt.Expr
62inlinedCase expr decisionTree jumpTargets =
63 let
64 substitutionDict =
65 gatherSubstitutions decisionTree
67 (jumps, sharedBranches) =
68 unzip (map (toJumps substitutionDict) jumpTargets)
69 in
70 Opt.Case
71 expr
72 (inlineJumps (Map.fromList jumps) decisionTree)
73 (Maybe.catMaybes sharedBranches)
76gatherSubstitutions
77 :: DT.DecisionTree DT.Jump
78 -> Map.Map Int [[(String, DT.Path)]]
79gatherSubstitutions decisionTree =
80 case decisionTree of
81 DT.Decision _ edges fallback ->
82 map snd edges
83 |> maybe id (:) fallback
84 |> map gatherSubstitutions
85 |> Map.unionsWith (++)
87 DT.Match (DT.Jump target substitutions) ->
88 Map.singleton target [substitutions]
91toJumps
92 :: Map.Map Int [[(String, DT.Path)]]
93 -> (Int, Opt.Expr)
94 -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )
95toJumps substitutionDict (target, branch) =
96 case substitutionDict ! target of
97 [substitutions] ->
98 ( (target, Opt.Inline (Opt.Branch substitutions branch))
99 , Nothing
100 )
102 substitutions : _ ->
103 ( (target, Opt.Jump target)
104 , Just (target, Opt.Branch substitutions branch)
105 )
107 _ ->
108 error "it is not possible for there to be no substitutions"
111inlineJumps
112 :: Map.Map Int Opt.Jump
113 -> DT.DecisionTree DT.Jump
114 -> DT.DecisionTree Opt.Jump
115inlineJumps jumpDict decisionTree =
116 let
117 go =
118 inlineJumps jumpDict
119 in
120 case decisionTree of
121 DT.Decision test edges fallback ->
122 DT.Decision test (map (second go) edges) (fmap go fallback)
124 DT.Match (DT.Jump target _) ->
125 DT.Match (jumpDict ! target)