git.iko.soy/elk
on ac43b4c help sign in
elk/src/Optimize/Patterns.hs
118 lines 3.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 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 Int
59 -> [(Int, Opt.Expr)]
60 -> Opt.Expr
61inlinedCase name decisionTree jumpTargets =
62 let
63 targetCounts =
64 countTargets decisionTree
66 (decisions, sharedBranches) =
67 unzip (map (toDecisions targetCounts) jumpTargets)
68 in
69 Opt.Case
70 name
71 (inlineDecisions (Map.fromList decisions) decisionTree)
72 (Maybe.catMaybes sharedBranches)
75countTargets :: DT.DecisionTree Int -> Map.Map Int Int
76countTargets decisionTree =
77 case decisionTree of
78 DT.Decision _ edges fallback ->
79 map snd edges
80 |> maybe id (:) fallback
81 |> map countTargets
82 |> Map.unionsWith (+)
84 DT.Match target ->
85 Map.singleton target 1
88toDecisions
89 :: Map.Map Int Int
90 -> (Int, Opt.Expr)
91 -> ( (Int, Opt.Decision), Maybe (Int, Opt.Expr) )
92toDecisions targetCounts (target, branch) =
93 if targetCounts ! target == 1 then
94 ( (target, Opt.Inline branch)
95 , Nothing
96 )
98 else
99 ( (target, Opt.Jump target)
100 , Just (target, branch)
101 )
104inlineDecisions
105 :: Map.Map Int Opt.Decision
106 -> DT.DecisionTree Int
107 -> DT.DecisionTree Opt.Decision
108inlineDecisions jumpDict decisionTree =
109 let
110 go =
111 inlineDecisions jumpDict
112 in
113 case decisionTree of
114 DT.Decision test edges fallback ->
115 DT.Decision test (map (second go) edges) (fmap go fallback)
117 DT.Match target ->
118 DT.Match (jumpDict ! target)