git.iko.soy/elk
on f4ea9e3 help sign in
elk/src/Optimize/Patterns.hs
124 lines 3.4 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 Elm.Utils ((|>))
12import qualified Optimize.Environment as Env
13import qualified Optimize.Patterns.DecisionTree as DT
14import qualified Reporting.Annotation as A
15import qualified Reporting.Region as R
18optimize
19 :: DT.VariantDict
20 -> R.Region
21 -> Opt.Expr
22 -> [(P.CanonicalPattern, Opt.Expr)]
23 -> Env.Optimizer Opt.Expr
24optimize 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)])
39 _ ->
40 return optBranches
42 let (patterns, indexedBranches) =
43 unzip (zipWith indexify [0..] crashBranches)
45 let decisionTree =
46 DT.compile variantDict patterns
48 tempName <- Env.freshName
50 return $
51 Opt.Let
52 [ Opt.Def Opt.dummyFacts tempName optExpr ]
53 (inlinedCase tempName decisionTree indexedBranches)
56inlinedCase
57 :: String
58 -> DT.DecisionTree DT.Jump
59 -> [(Int, Opt.Expr)]
60 -> Opt.Expr
61inlinedCase name decisionTree jumpTargets =
62 let
63 substitutionDict =
64 gatherSubstitutions decisionTree
66 (jumps, sharedBranches) =
67 unzip (map (toJumps substitutionDict) jumpTargets)
68 in
69 Opt.Case
70 name
71 (inlineJumps (Map.fromList jumps) decisionTree)
72 (Maybe.catMaybes sharedBranches)
75gatherSubstitutions
76 :: DT.DecisionTree DT.Jump
77 -> Map.Map Int [[(String, DT.Path)]]
78gatherSubstitutions decisionTree =
79 case decisionTree of
80 DT.Decision _ edges fallback ->
81 map snd edges
82 |> maybe id (:) fallback
83 |> map gatherSubstitutions
84 |> Map.unionsWith (++)
86 DT.Match (DT.Jump target substitutions) ->
87 Map.singleton target [substitutions]
90toJumps
91 :: Map.Map Int [[(String, DT.Path)]]
92 -> (Int, Opt.Expr)
93 -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )
94toJumps substitutionDict (target, branch) =
95 case substitutionDict ! target of
96 [substitutions] ->
97 ( (target, Opt.Inline (Opt.Branch substitutions branch))
98 , Nothing
99 )
101 substitutions : _ ->
102 ( (target, Opt.Jump target)
103 , Just (target, Opt.Branch substitutions branch)
104 )
106 _ ->
107 error "it is not possible for there to be no substitutions"
110inlineJumps
111 :: Map.Map Int Opt.Jump
112 -> DT.DecisionTree DT.Jump
113 -> DT.DecisionTree Opt.Jump
114inlineJumps jumpDict decisionTree =
115 let
116 go =
117 inlineJumps jumpDict
118 in
119 case decisionTree of
120 DT.Decision test edges fallback ->
121 DT.Decision test (map (second go) edges) (fmap go fallback)
123 DT.Match (DT.Jump target _) ->
124 DT.Match (jumpDict ! target)