git.iko.soy/elk
on master help sign in
Begin reviving the optimize phase
2da8c0dEvan Czaplicki
src/AST/Optimized.hs+94−111
compare with master
unifiedsplit
@@ -1,22 +1,24 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module AST.Optimized
2module AST.Optimized
3− ( Decl(..)
4− , Def(..)
3+ ( Def(..)
5 , Expr(..)
4 , Expr(..)
6− , Main(..)
5+ , Global(..)
7− , Decider(..), Choice(..)
6+ , Decider(..)
7+ , Choice(..)
8+ , Graph(..)
9+ , Node(..)
8 )
10 )
9 where
11 where
10
12
11
13
12import Control.Monad (liftM, liftM2, liftM3, liftM4)
14import Control.Monad (liftM, liftM2, liftM3, liftM4)
13import Data.Binary
15import Data.Binary
14−import qualified Data.Set as Set
16+import qualified Data.Map as Map
15import Data.Text (Text)
17import Data.Text (Text)
16
18
17−import qualified AST.Literal as Literal
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Module.Name as ModuleName
19−import qualified AST.Variable as Var
20+import qualified Data.Index as Index
21+import qualified Elm.Name as N
20import qualified Optimize.DecisionTree as DT
22import qualified Optimize.DecisionTree as DT
21import qualified Reporting.Region as R
23import qualified Reporting.Region as R
22
24
@@ -26,27 +28,34 @@ import qualified Reporting.Region as R
26
28
27
29
28data Expr
30data Expr
29− = Literal Literal.Literal
31+ = Chr Text
32+ | Str Text
33+ | Int Int
34+ | Float Double
30− | VarLocal Text
35+ | VarLocal N.Name
31− | VarGlobal Var.Global
36+ | VarGlobal Global
37+ | VarDebug N.Name ModuleName.Canonical R.Region (Maybe Expr)
38+ | VarKernel N.Name N.Name
32 | List [Expr]
39 | List [Expr]
33− | Binop Var.Global Expr Expr
34− | Function [Text] Expr
40+ | Function [N.Name] Expr
35 | Call Expr [Expr]
41 | Call Expr [Expr]
36− | TailCall Text [Text] [Expr]
42+ | TailCall N.Name [N.Name] [Expr]
37 | If [(Expr, Expr)] Expr
43 | If [(Expr, Expr)] Expr
38− | Let [(Text, Def)] Expr
44+ | Let Def Expr
39− | Case Text (Decider Choice) [(Int, Expr)]
45+ | Case N.Name (Decider Choice) [(Int, Expr)]
40− | Ctor Text [Expr]
46+ | Ctor N.Name [Expr]
41− | CtorAccess Expr Int
47+ | CtorAccess Expr Index.ZeroBased
42− | Accessor Text
48+ | Accessor N.Name
43− | Access Expr Text
49+ | Access Expr N.Name
44− | Update Expr [(Text, Expr)]
50+ | Update Expr (Map.Map N.Name Expr)
45− | Record [(Text, Expr)]
51+ | Record (Map.Map N.Name Expr)
46 | Unit
52 | Unit
47− | Tuple Expr Expr [Expr]
53+ | Tuple Expr Expr (Maybe Expr)
48− | GLShader Text
54+ | Shader Text
55+
56+
49− | Crash ModuleName.Canonical R.Region (Maybe Expr)
57+data Global = Global ModuleName.Canonical N.Name
58+ deriving (Eq, Ord)
50
59
51
60
52
61
@@ -54,8 +63,8 @@ data Expr
54
63
55
64
56data Def
65data Def
57− = Def Expr
66+ = Def N.Name Expr
58− | TailDef [Text] Expr
67+ | TailDef N.Name [N.Name] Expr
59
68
60
69
61
70
@@ -88,120 +97,94 @@ data Choice
88
97
89data Graph =
98data Graph =
90 Graph
99 Graph
91− { _nodes :: Map.Map Var.Global Node
100+ { _nodes :: Map.Map Global Node
92 }
101 }
93
102
94
103
95−
96−data Node
104+data Node = Node
97− = Acyclic
98− { _deps :: [Var.Global]
99− , _body :: Expr
100− }
101− | TailCall
102− { _deps :: [Var.Global]
103− , _args :: [Text]
104− , _body :: Expr
105− }
106− | Cyclic Var.Global
107− | Cycle
108− { _deps :: [Var.Global]
109− , _values :: [(Var.Global, Expr)]
110− }
111
105
112
106
113
107
114-- BINARY
108-- BINARY
115
109
116
110
111+instance Binary Global where
112+ get = liftM2 Global get get
113+ put (Global a b) = put a >> put b
114+
115+
117instance Binary Expr where
116instance Binary Expr where
118 put expr =
117 put expr =
119 case expr of
118 case expr of
120− Literal a -> putWord8 0 >> put a
119+ Chr a -> putWord8 0 >> put a
121− VarLocal a -> putWord8 1 >> put a
120+ Str a -> putWord8 1 >> put a
122− VarGlobal a -> putWord8 2 >> put a
121+ Int a -> putWord8 2 >> put a
123− List a -> putWord8 3 >> put a
122+ Float a -> putWord8 3 >> put a
124− Binop a b c -> putWord8 4 >> put a >> put b >> put c
123+ VarLocal a -> putWord8 4 >> put a
125− Function a b -> putWord8 5 >> put a >> put b
124+ VarGlobal a -> putWord8 5 >> put a
126− Call a b -> putWord8 6 >> put a >> put b
125+ VarDebug a b c d -> putWord8 6 >> put a >> put b >> put c >> put d
127− TailCall a b c -> putWord8 7 >> put a >> put b >> put c
126+ VarKernel a b -> putWord8 7 >> put a >> put b
128− If a b -> putWord8 8 >> put a >> put b
127+ List a -> putWord8 8 >> put a
129− Let a b -> putWord8 9 >> put a >> put b
128+ Function a b -> putWord8 9 >> put a >> put b
130− Case a b c -> putWord8 10 >> put a >> put b >> put c
129+ Call a b -> putWord8 10 >> put a >> put b
131− Ctor a b -> putWord8 11 >> put a >> put b
130+ TailCall a b c -> putWord8 11 >> put a >> put b >> put c
132− CtorAccess a b -> putWord8 12 >> put a >> put b
131+ If a b -> putWord8 12 >> put a >> put b
133− Accessor a -> putWord8 13 >> put a
132+ Let a b -> putWord8 13 >> put a >> put b
134− Access a b -> putWord8 14 >> put a >> put b
133+ Case a b c -> putWord8 14 >> put a >> put b >> put c
135− Update a b -> putWord8 15 >> put a >> put b
134+ Ctor a b -> putWord8 15 >> put a >> put b
136− Record a -> putWord8 16 >> put a
135+ CtorAccess a b -> putWord8 16 >> put a >> put b
137− Unit -> putWord8 17
136+ Accessor a -> putWord8 17 >> put a
138− Tuple a b c -> putWord8 18 >> put a >> put b >> put c
137+ Access a b -> putWord8 18 >> put a >> put b
139− GLShader a -> putWord8 19 >> put a
138+ Update a b -> putWord8 19 >> put a >> put b
140− Crash a b c -> putWord8 20 >> put a >> put b >> put c
139+ Record a -> putWord8 20 >> put a
140+ Unit -> putWord8 21
141+ Tuple a b c -> putWord8 22 >> put a >> put b >> put c
142+ Shader a -> putWord8 23 >> put a
141
143
142 get =
144 get =
143 do word <- getWord8
145 do word <- getWord8
144 case word of
146 case word of
145− 0 -> liftM Literal get
147+ 0 -> liftM Chr get
146− 1 -> liftM VarLocal get
148+ 1 -> liftM Str get
147− 2 -> liftM VarGlobal get
149+ 2 -> liftM Int get
148− 3 -> liftM List get
150+ 3 -> liftM Float get
149− 4 -> liftM3 Binop get get get
151+ 4 -> liftM VarLocal get
150− 5 -> liftM2 Function get get
152+ 5 -> liftM VarGlobal get
151− 6 -> liftM2 Call get get
153+ 6 -> liftM4 VarDebug get get get get
152− 7 -> liftM3 TailCall get get get
154+ 7 -> liftM2 VarKernel get get
153− 8 -> liftM2 If get get
155+ 8 -> liftM List get
154− 9 -> liftM2 Let get get
156+ 9 -> liftM2 Function get get
155− 10 -> liftM3 Case get get get
157+ 10 -> liftM2 Call get get
156− 11 -> liftM2 Ctor get get
158+ 11 -> liftM3 TailCall get get get
157− 12 -> liftM2 CtorAccess get get
159+ 12 -> liftM2 If get get
158− 13 -> liftM Accessor get
160+ 13 -> liftM2 Let get get
159− 14 -> liftM2 Access get get
161+ 14 -> liftM3 Case get get get
160− 15 -> liftM2 Update get get
162+ 15 -> liftM2 Ctor get get
161− 16 -> liftM Record get
163+ 16 -> liftM2 CtorAccess get get
164+ 17 -> liftM Accessor get
165+ 18 -> liftM2 Access get get
166+ 19 -> liftM2 Update get get
167+ 20 -> liftM Record get
162− 17 -> pure Unit
168+ 21 -> pure Unit
163− 18 -> liftM3 Tuple get get get
169+ 22 -> liftM3 Tuple get get get
164− 19 -> liftM GLShader get
170+ 23 -> liftM Shader get
165− 20 -> liftM3 Crash get get get
166 _ -> error "problem getting Opt.Expr binary"
171 _ -> error "problem getting Opt.Expr binary"
167
172
168
173
169−instance Binary Decl where
170− put (Decl a b c d) =
171− put a >> put b >> put c >> put d
172−
173− get =
174− liftM4 Decl get get get get
175−
176−
177instance Binary Def where
174instance Binary Def where
178 put def =
175 put def =
179 case def of
176 case def of
180− Def body -> putWord8 0 >> put body
177+ Def a b -> putWord8 0 >> put a >> put b
181− TailDef args body -> putWord8 1 >> put args >> put body
178+ TailDef a b c -> putWord8 1 >> put a >> put b >> put c
182
179
183 get =
180 get =
184 do word <- getWord8
181 do word <- getWord8
185 case word of
182 case word of
186− 0 -> Def <$> get
183+ 0 -> liftM2 Def get get
187− 1 -> TailDef <$> get <*> get
184+ 1 -> liftM3 TailDef get get get
188 _ -> error "problem getting Opt.Def binary"
185 _ -> error "problem getting Opt.Def binary"
189
186
190
187
191−instance Binary Main where
192− put main =
193− case main of
194− Static -> putWord8 0
195− Dynamic expr -> putWord8 1 >> put expr
196−
197− get =
198− do word <- getWord8
199− case word of
200− 0 -> pure Static
201− 1 -> liftM Dynamic get
202− _ -> error "problem getting Opt.Main binary"
203−
204−
205instance (Binary a) => Binary (Decider a) where
188instance (Binary a) => Binary (Decider a) where
206 put decider =
189 put decider =
207 case decider of
190 case decider of
src/AST/Variable.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module AST.Variable
4− ( Global(..)
5− )
6− where
7−
8−
9−import Data.Binary
10−
11−import qualified AST.Module.Name as ModuleName
12−import qualified Elm.Name as N
13−
14−
15−
16−-- GLOBAL NAMES
17−
18−
19−data Global = Global !ModuleName.Canonical !N.Name
20− deriving (Eq, Ord)
21−
22−
23−
24−-- BINARY SERIALIZATION
25−
26−
27−instance Binary Global where
28− put (Global home name) =
29− put home >> put name
30−
31− get =
32− Global <$> get <*> get
src/Data/Index.hs+14−2
@@ -15,13 +15,16 @@ module Data.Index
15 where
15 where
16
16
17
17
18+import Control.Monad (liftM)
19+import Data.Binary
20+
18
21
19
22
20-- ZERO BASED
23-- ZERO BASED
21
24
22
25
23−newtype ZeroBased =
26+newtype ZeroBased = ZeroBased Int
24− ZeroBased Int
27+ deriving (Eq, Ord)
25
28
26
29
27first :: ZeroBased
30first :: ZeroBased
@@ -112,3 +115,12 @@ indexedZipWithA func listX listY =
112
115
113 LengthMismatch x y ->
116 LengthMismatch x y ->
114 pure (LengthMismatch x y)
117 pure (LengthMismatch x y)
118+
119+
120+
121+-- BINARY
122+
123+
124+instance Binary ZeroBased where
125+ get = liftM ZeroBased get
126+ put (ZeroBased n) = put n
src/Optimize.hs+273−465
@@ -1,25 +1,23 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Optimize (optimize) where
3+module Optimize
4−
4+ ( optimizeExpr
5−import Control.Arrow (second)
5+ )
6+ where
7+
8+
6−import qualified Control.Monad as M
9+import Control.Monad (foldM)
7−import Data.Monoid ((<>))
10+
8−import qualified Data.Map as Map
9−import qualified Data.Set as Set
10−import qualified Data.Text as Text
11−import Data.Text (Text)
12−
13−import qualified AST.Expression.Canonical as Can
11+import qualified AST.Canonical as Can
14−import qualified AST.Expression.Optimized as Opt
12+import qualified AST.Optimized as Opt
15import qualified AST.Module.Name as ModuleName
13import qualified AST.Module.Name as ModuleName
16−import qualified AST.Pattern as P
14+import qualified Data.Index as Index
17−import qualified AST.Variable as Var
15+import qualified Elm.Name as N
18−import qualified Optimize.Case as Case
16+--import qualified Optimize.Case as Case
19import qualified Optimize.DecisionTree as DT
17import qualified Optimize.DecisionTree as DT
20−import qualified Optimize.Environment as Env
18+import qualified Optimize.Names as Names
21−import qualified Optimize.Inline as Inline
19+--import qualified Optimize.Inline as Inline
22−import qualified Optimize.Port as Port
20+--import qualified Optimize.Port as Port
23import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
24import qualified Reporting.Region as R
22import qualified Reporting.Region as R
25
23
@@ -28,543 +26,353 @@ import qualified Reporting.Region as R
28-- OPTIMIZE
26-- OPTIMIZE
29
27
30
28
31−optimize :: DT.VariantDict -> ModuleName.Canonical -> [Can.Def] -> [(Text, Opt.Decl)]
32−optimize variantDict home defs =
33− concat $ zipWith (optimizeDecl variantDict home) [1 .. length defs] defs
34−
35−
36−
37−-- OPTIMIZE DECLS
38−
39−
40−optimizeDecl :: DT.VariantDict -> ModuleName.Canonical -> Int -> Can.Def -> [(Text, Opt.Decl)]
41−optimizeDecl variantDict home index (Can.Def _ pattern@(A.A _ ptrn) expression _) =
42− let
43− (rawArgs, rawBody) =
44− Can.collectLambdas expression
45− in
46− case (ptrn, rawArgs) of
47− (P.Var name, _) ->
48− (:[]) $ Env.run variantDict home $
49− optimizeNamedDef name rawArgs rawBody
50−
51− (_, []) ->
52− let
53− name = "_" <> Text.pack (show index)
54− var = Var.Global home name
55− deps = Set.singleton var
56− decl =
57− Env.run variantDict home $
58− ((,) name . Opt.Def) <$> optimizeExpr Nothing rawBody
59− destructors =
60− destruct (Opt.VarGlobal var) pattern
61− in
62− decl : map (second (Opt.Decl deps Set.empty Nothing)) destructors
63−
64− _ ->
65− error "bug manifesting in Optimize.optimizeDecl, please report"
66−
67−
68−
69−-- OPTIMIZE DEFS
70−
71−
72−optimizeLetDef :: Can.Def -> Env.Optimizer [(Text, Opt.Def)]
73−optimizeLetDef (Can.Def _ pattern@(A.A _ ptrn) expression _) =
74− let
75− (rawArgs, rawBody) =
76− Can.collectLambdas expression
77− in
78− case (ptrn, rawArgs) of
79− (P.Var name, _) ->
80− do def <- optimizeNamedDef name rawArgs rawBody
81− return [def]
82−
83− (_, []) ->
84− do name <- Env.freshName
85− body <- optimizeExpr Nothing rawBody
86− return $ (name, Opt.Def body) : destruct (Opt.VarLocal name) pattern
87−
88− _ ->
89− error "bug manifesting in Optimize.optimizeLetDef, please report"
90−
91−
92−optimizeNamedDef :: Text -> [P.Canonical] -> Can.Expr -> Env.Optimizer (Text, Opt.Def)
93−optimizeNamedDef name rawArgs rawBody =
94− case rawArgs of
95− [] ->
96− do hasTailCall <- Env.getTailCall
97− body <- optimizeExpr Nothing rawBody
98− Env.setTailCall hasTailCall
99− return (name, Opt.Def body)
100−
101− _ : _ ->
102− do htc <- Env.getTailCall
103− Env.setTailCall False
104
29
105− (args, body) <- optimizeFunction (Just name) rawArgs rawBody
30+-- EXPRESSIONS
106
31
107− isTailCall <- Env.getTailCall
108− Env.setTailCall htc
109−
110− return $ (,) name $
111− if isTailCall then
112− Opt.TailDef args body
113− else
114− Opt.Def (Opt.Function args body)
115−
116−
117−destruct :: Opt.Expr -> P.Canonical -> [(Text, Opt.Def)]
118−destruct root pattern =
119− map (second Opt.Def) $
120− patternToSubstitutions root pattern
121−
122−
123−
124−-- OPTIMIZE FUNCTION
125−
126−
127−optimizeFunction
128− :: Maybe Text
129− -> [P.Canonical]
130− -> Can.Expr
131− -> Env.Optimizer ([Text], Opt.Expr)
132−optimizeFunction maybeName patterns givenBody =
133− Env.indirectly $
134− do (argNames, body) <- M.foldM depatternArgs ([], givenBody) (reverse patterns)
135− optBody <- optimizeExpr (makeContext argNames =<< maybeName) body
136− return (argNames, optBody)
137−
138−
139−makeContext :: [Text] -> Text -> Context
140−makeContext argNames name =
141− Just (name, length argNames, argNames)
142−
143−
144−depatternArgs :: ([Text], Can.Expr) -> P.Canonical -> Env.Optimizer ([Text], Can.Expr)
145−depatternArgs (names, rawExpr) ptrn =
146− do (name, expr) <- depattern ptrn rawExpr
147− return (name : names, expr)
148−
149−
150−
151−-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS
152
32
33+optimizeExpr :: Can.Expr -> Names.Tracker Opt.Expr
34+optimizeExpr (A.At region expression) =
35+ case expression of
36+ Can.VarLocal name ->
37+ pure (Opt.VarLocal name)
153
38
154−patternToSubstitutions :: Opt.Expr -> P.Canonical -> [(Text, Opt.Expr)]
39+ Can.VarTopLevel home name ->
155−patternToSubstitutions expr (A.A _ pattern) =
40+ Names.registerGlobal home name
156− case pattern of
157− P.Var name ->
158− [ (name, expr) ]
159
41
160− P.Literal _ ->
42+ Can.VarKernel home name ->
161− []
43+ Names.registerKernel home (Opt.VarKernel home name)
162
44
163− P.Record fields ->
45+ Can.VarForeign home name _ ->
164− map (\name -> (name, Opt.Access expr name)) fields
46+ Names.registerGlobal home name
165
47
166− P.Anything ->
48+ Can.VarDebug home name _ ->
167− []
49+ Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)
168
50
169− P.Alias alias realPattern ->
51+ Can.VarOperator _ home name _ ->
170− (alias, expr) : patternToSubstitutions expr realPattern
52+ Names.registerGlobal home name
171
53
172− P.Ctor _ patterns ->
54+ Can.Chr chr ->
173− concat (zipWith (patternToSubstitutions . Opt.CtorAccess expr) [0..] patterns)
55+ pure (Opt.Chr chr)
174
56
57+ Can.Str str ->
58+ pure (Opt.Str str)
175
59
60+ Can.Int int ->
61+ pure (Opt.Int int)
176
62
177−-- OPTIMIZE EXPRESSIONS
63+ Can.Float float ->
64+ pure (Opt.Float float)
178
65
66+ Can.List entries ->
67+ Opt.List <$> traverse optimizeExpr entries
179
68
180−type Context = Maybe (Text, Int, [Text])
69+ Can.Negate expr ->
70+ do func <- Names.registerGlobal ModuleName.basics N.negate
71+ arg <- optimizeExpr expr
72+ pure $ Opt.Call func [arg]
181
73
74+ Can.Binop _ home name _ left right ->
75+ do optFunc <- Names.registerGlobal home name
76+ optLeft <- optimizeExpr left
77+ optRight <- optimizeExpr right
78+ return (Opt.Call optFunc [optLeft, optRight])
182
79
183−{-| This optimizer detects tail calls. The `Context` holds a function name,
80+ Can.Lambda args body ->
184−function arity, and list of argument names. If a tail call is possible, the
81+ do (argNames, defss) <- destructArgs args
185−`Context` will be filled in and we check any function we run into. If we go
82+ obody <- optimizeExpr body
186−down a route that cannot possibly have tail calls, we remove the context.
83+ pure $
187−-}
84+ Opt.Function argNames (foldr Opt.Let obody (concat defss))
188−optimizeExpr :: Context -> Can.Expr -> Env.Optimizer Opt.Expr
189−optimizeExpr context annExpr@(A.A region expression) =
190− let
191− keepLooking =
192− optimizeExpr context
193− -- this *might* find a tail call, use this when something is a potential
194− -- tail call
195
85
196− justConvert =
86+ Can.Call func args ->
197− optimizeExpr Nothing
198− -- this will never find tail calls, use this when you are working with
199− -- expressions that cannot be turned into tail calls
200− in
201− case expression of
202− Can.Literal lit ->
203− pure (Opt.Literal lit)
204−
205− Can.Var var ->
206− optimizeVariable region var
207−
208− Can.List elements ->
209− Opt.List
87+ Opt.Call
210− <$> traverse justConvert elements
88+ <$> optimizeExpr func
211−
212− Can.Binop op leftExpr rightExpr ->
213− optimizeBinop context region op leftExpr rightExpr
214−
215− Can.Lambda _ _ ->
216− let
217− (patterns, body) =
218− Can.collectLambdas annExpr
219− in
220− uncurry Opt.Function <$> optimizeFunction Nothing patterns body
221−
222− Can.App _ _ ->
223− let
224− (func:args) =
225− Can.collectApps annExpr
226− in
227− case getTailCallInfo context func (length args) of
228− Just (name, argNames) ->
229− do optArgs <- traverse justConvert args
230− Env.setTailCall True
231− return (Opt.TailCall name argNames optArgs)
232−
233− Nothing ->
234− do hasTailCall <- Env.getTailCall
235− optFunc <- justConvert func
236− optArgs <- traverse justConvert args
89+ <*> traverse optimizeExpr args
237− Env.setTailCall hasTailCall
238− return (Opt.Call optFunc optArgs)
239
90
240 Can.If branches finally ->
91 Can.If branches finally ->
241− let
92+ let
242− crawlBranch (cond,branch) =
93+ optimizeBranch (condition, branch) =
243− (,) <$> justConvert cond <*> keepLooking branch
94+ (,)
95+ <$> optimizeExpr condition
96+ <*> optimizeExpr branch
244− in
97+ in
245− Opt.If
98+ Opt.If
246− <$> traverse crawlBranch branches
99+ <$> traverse optimizeBranch branches
247− <*> keepLooking finally
100+ <*> optimizeExpr finally
248−
101+
102+ Can.Let def body ->
103+ optimizeDef def =<< optimizeExpr body
104+
249− Can.Let defs body ->
105+ Can.LetRec defs body ->
250− do optDefs <- concat <$> traverse optimizeLetDef defs
106+ case defs of
251− Opt.Let optDefs <$> keepLooking body
107+ [def] ->
108+ Opt.Let
109+ <$> optimizePotentialTailCall def
110+ <*> optimizeExpr body
111+
112+ _ ->
113+ do obody <- optimizeExpr body
114+ foldM (\bod def -> optimizeDef def bod) obody defs
115+
116+ Can.LetDestruct pattern expr body ->
117+ do (name, defs) <- destruct pattern
118+ oexpr <- optimizeExpr expr
119+ obody <- optimizeExpr body
120+ pure $
121+ Opt.Let (Opt.Def name oexpr) (foldr Opt.Let obody defs)
252
122
253 Can.Case expr branches ->
123 Can.Case expr branches ->
254− do optExpr <- optimizeExpr Nothing expr
124+ error "TODO"
255− variantDict <- Env.getVariantDict
256−
257− name <- Env.freshName
258− optBranches <- traverse (optimizeBranch context region name) branches
259− let optCase = Case.optimize variantDict name optBranches
260− return $ Opt.Let [ (name, Opt.Def optExpr) ] optCase
261
125
262− Can.Ctor (Var.Canonical _ name) exprs ->
126+ Can.Accessor field ->
263− Opt.Ctor name <$> traverse justConvert exprs
127+ pure (Opt.Accessor field)
264
128
265 Can.Access record field ->
129 Can.Access record field ->
130+ do optRecord <- optimizeExpr record
266− Opt.Access
131+ pure (Opt.Access optRecord field)
267− <$> justConvert record
268− <*> pure field
269
132
270− Can.Update record fields ->
133+ Can.Update record updates ->
271− Opt.Update
134+ Opt.Update
272− <$> justConvert record
135+ <$> optimizeExpr record
273− <*> traverse (traverse justConvert) fields
136+ <*> traverse optimizeExpr updates
274
137
275 Can.Record fields ->
138 Can.Record fields ->
276− Opt.Record
277− <$> traverse (traverse justConvert) fields
139+ Opt.Record <$> traverse optimizeExpr fields
278
140
279− Can.Cmd home manager ->
141+ Can.Unit ->
280− Opt.Cmd home <$> Env.registerEffects home manager
142+ Names.registerKernel N.utils Opt.Unit
281
143
282− Can.Sub home manager ->
144+ Can.Tuple a b maybeC ->
283− Opt.Sub home <$> Env.registerEffects home manager
145+ Names.registerKernel N.utils Opt.Tuple
146+ <*> optimizeExpr a
147+ <*> optimizeExpr b
148+ <*> traverse optimizeExpr maybeC
284
149
285− Can.OutgoingPort name tipe ->
150+ Can.Shader _ src _ ->
286− Opt.OutgoingPort name <$> Port.toEncoder tipe
151+ pure (Opt.Shader src)
287
152
288− Can.IncomingPort name tipe ->
289− Opt.IncomingPort name <$> Port.toDecoder tipe
290
153
291− Can.Program main expr ->
292− Opt.Program <$> optimizeMain main <*> justConvert expr
293
154
294− Can.SaveEnv _ _ ->
155+-- DEFINITION
295− error "save_the_environment should never make it to optimization phase"
296
156
297− Can.GLShader _ src _ ->
298− pure (Opt.GLShader src)
299
157
158+optimizeDef :: Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr
159+optimizeDef def body =
160+ case def of
161+ Can.Def (A.At _ name) args expr ->
162+ optimizeDefHelp name args expr body
300
163
164+ Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
165+ optimizeDefHelp name (map fst typedArgs) expr body
301
166
302−-- OPTIMIZE VARIABLE
303
167
304−
168+optimizeDefHelp :: N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr
305−optimizeVariable :: R.Region -> Var.Canonical -> Env.Optimizer Opt.Expr
169+optimizeDefHelp name args expr body =
306−optimizeVariable region (Var.Canonical home name) =
307− case home of
308− Var.BuiltIn ->
309− pure (Opt.VarLocal name)
310−
311− Var.Local ->
312− pure (Opt.VarLocal name)
313−
314− Var.TopLevel modul ->
315− do let var = Var.Global modul name
316− Env.register var
317− pure (Opt.VarGlobal var)
318−
319− Var.Module modul ->
320− do let var = Var.Global modul name
321− Env.register var
322− if name == "crash" && modul == ModuleName.inCore "Debug"
323− then
324− do here <- Env.getHome
325− pure (Opt.Crash here region Nothing)
326− else
327− pure (Opt.VarGlobal var)
328−
329−
330−
331−-- OPTIMIZE MAIN
332−
333−
334−optimizeMain :: Can.Main -> Env.Optimizer Opt.Main
335−optimizeMain main =
336− case main of
170+ case args of
337− Can.Static ->
171+ [] ->
338− return Opt.Static
339−
340− Can.Dynamic tipe ->
341− Opt.Dynamic <$> Port.toFlagsDecoder tipe
342−
343−
344−
345−-- OPTIMIZE CASE BRANCHES
346−
347−
348−optimizeBranch
349− :: Context
350− -> R.Region
351− -> Text
352− -> (P.Canonical, Can.Expr)
353− -> Env.Optimizer (P.Canonical, Opt.Expr)
354−optimizeBranch context region exprName (rawPattern, canBranch) =
355− do optBranch <- optimizeExpr context canBranch
172+ do oexpr <- optimizeExpr expr
356− (pattern, branch) <- tagCrashBranch region rawPattern optBranch
173+ pure $ Opt.Let (Opt.Def name oexpr) body
357−
358− let substitutions = Map.fromList $
359− patternToSubstitutions (Opt.VarLocal exprName) pattern
360−
361− (,) pattern <$> Inline.inline substitutions branch
362−
363−
364−tagCrashBranch
365− :: R.Region
366− -> P.Canonical
367− -> Opt.Expr
368− -> Env.Optimizer (P.Canonical, Opt.Expr)
369−tagCrashBranch region pattern@(A.A pr _) expr =
370− case expr of
371− Opt.Call (Opt.Crash home _ _) [arg] ->
372− do name <- Env.freshName
373− return
374− ( A.A pr (P.Alias name pattern)
375− , Opt.Call (Opt.Crash home region (Just (Opt.VarLocal name))) [arg]
376− )
377
174
378 _ ->
175 _ ->
379− return (pattern, expr)
176+ do (argNames, defss) <- destructArgs args
380−
177+ let func = Opt.Function argNames (foldr Opt.Let body (concat defss))
381−
178+ pure $
382−
179+ Opt.Let (Opt.Def name func) body
383−-- DETECT TAIL CALL
384
180
385
181
386−getTailCallInfo :: Context -> Can.Expr -> Int -> Maybe (Text, [Text])
387−getTailCallInfo context (A.A _ function) arity =
388− case (context, function) of
389− ( Just (ctxName, ctxArity, argNames), Can.Var (Var.Canonical home name) ) ->
390
182
391− if name == ctxName && arity == ctxArity && Var.isLocalHome home then
183+-- DESTRUCTURING
392− Just (name, argNames)
393
184
394− else
395− Nothing
396
185
397− _ ->
186+destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [[Opt.Def]])
398− Nothing
187+destructArgs args =
188+ unzip <$> traverse destruct args
399
189
400
190
191+destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Def])
192+destruct pattern@(A.At _ ptrn) =
193+ case ptrn of
194+ Can.PVar name ->
195+ pure (name, [])
401
196
402−-- DEPATTERN
197+ Can.PAlias subPattern name ->
403−-- given a pattern and an expression, push the actual pattern matching into the
198+ do revDefs <- destructHelp (Opt.VarLocal name) subPattern []
404−-- expression as a case-expression if necessary. The pattern compiler will work
199+ pure (name, reverse revDefs)
405−-- it out from there
406
200
201+ _ ->
202+ do name <- Names.generate
203+ revDefs <- destructHelp (Opt.VarLocal name) pattern []
204+ pure (name, reverse revDefs)
407
205
408−depattern :: P.Canonical -> Can.Expr -> Env.Optimizer (Text, Can.Expr)
409−depattern canPattern@(A.A _ pattern) expr =
410− let
411− ann =
412− A.A (error "the annotation added in 'depattern' should not be observed!")
413−
414− caseExpr e branches =
415− ann (Can.Case e branches)
416−
417− var name =
418− ann (Can.Var (Var.local name))
419
206
420− caseify =
207+destructHelp :: Opt.Expr -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
421− do name <- Env.freshName
208+destructHelp root (A.At region pattern) revDefs =
422− return
423− ( name
424− , caseExpr (var name) [ (canPattern, expr) ]
425− )
426− in
427 case pattern of
209 case pattern of
428− P.Var name ->
210+ Can.PAnything ->
429− return (name, expr)
211+ pure revDefs
430
212
431− P.Literal _ ->
213+ Can.PVar name ->
432− caseify
214+ pure (Opt.Def name root : revDefs)
433
215
434− P.Record _ ->
216+ Can.PRecord fields ->
435− caseify
217+ let
218+ toDef field =
219+ Opt.Def field (Opt.Access root field)
220+ in
221+ pure (map toDef fields ++ revDefs)
436
222
437− P.Anything ->
223+ Can.PAlias subPattern name ->
438− do name <- Env.freshName
224+ destructHelp (Opt.VarLocal name) subPattern $
439− return (name, expr)
225+ Opt.Def name root : revDefs
440
226
441− P.Alias _ _ ->
227+ Can.PUnit ->
442− caseify
228+ pure revDefs
443
229
444− P.Ctor _ _ ->
230+ Can.PTuple a b maybeC ->
445− caseify
231+ do name <- Names.generate
232+ let tuple = Opt.VarLocal name
233+ let newRevDefs = Opt.Def name root : revDefs
234+ case maybeC of
235+ Nothing ->
236+ destructHelp (Opt.CtorAccess tuple Index.second) b =<<
237+ destructHelp (Opt.CtorAccess tuple Index.first) a newRevDefs
446
238
239+ Just c ->
240+ destructHelp (Opt.CtorAccess tuple Index.third) c =<<
241+ destructHelp (Opt.CtorAccess tuple Index.second) b =<<
242+ destructHelp (Opt.CtorAccess tuple Index.first) a newRevDefs
447
243
244+ Can.PList [] ->
245+ pure revDefs
448
246
449−-- OPTIMIZE BINOPS
247+ Can.PList (hd:tl) ->
248+ destructCons root hd (A.At region (Can.PList tl)) revDefs
450
249
250+ Can.PCons hd tl ->
251+ destructCons root hd tl revDefs
451
252
452−optimizeBinop
453− :: Context
454− -> R.Region
455− -> Var.Canonical
456− -> Can.Expr
253+ Can.PChr _ ->
457− -> Can.Expr
254+ pure revDefs
458− -> Env.Optimizer Opt.Expr
459−optimizeBinop context region op leftExpr rightExpr =
460− let
461− ann = A.A region
462− binop = ann (Can.Binop op leftExpr rightExpr)
463− in
464− if op == forwardApply then
465
255
466− optimizeExpr context (collect id left forwardApply binop)
256+ Can.PStr _ ->
257+ pure revDefs
467
258
468− else if op == backwardApply then
259+ Can.PInt _ ->
260+ pure revDefs
469
261
470− optimizeExpr context (collect id right backwardApply binop)
262+ Can.PCtor _ _ _ _ _ args ->
263+ do name <- Names.generate
264+ foldM
265+ (destructCtorArg (Opt.VarLocal name))
266+ (Opt.Def name root : revDefs)
267+ args
471
268
472− else if op == forwardCompose then
473
269
474− do var <- Env.freshName
270+destructCons :: Opt.Expr -> Can.Pattern -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
475− let makeRoot func = ann (Can.App func (ann (Can.Var (Var.local var))))
271+destructCons root hd tl revDefs =
476− let body = collect makeRoot left forwardCompose binop
272+ do name <- Names.generate
477− optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))
273+ let list = Opt.VarLocal name
274+ destructHelp (Opt.CtorAccess list Index.first) hd =<<
275+ destructHelp (Opt.CtorAccess list Index.second) tl (Opt.Def name root : revDefs)
478
276
479− else if op == backwardCompose then
480
277
481− do var <- Env.freshName
278+destructCtorArg :: Opt.Expr -> [Opt.Def] -> Can.PatternCtorArg -> Names.Tracker [Opt.Def]
482− let makeRoot func = ann (Can.App func (ann (Can.Var (Var.local var))))
279+destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =
483− let body = collect makeRoot right backwardCompose binop
280+ destructHelp (Opt.CtorAccess root index) arg revDefs
484− optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))
485
281
486− else if op == cons then
487
282
488− optimizeExpr context (ann (Can.Ctor cons [ leftExpr, rightExpr ]))
489−
490− else
491
283
492− do optLeft <- optimizeExpr Nothing leftExpr
284+-- TAIL CALL
493− optRight <- optimizeExpr Nothing rightExpr
494− makeOptBinop op optLeft optRight
495
285
496
286
497−-- left-associative ((x |> f) |> g)
287+optimizePotentialTailCall :: Can.Def -> Names.Tracker Opt.Def
498−forwardApply :: Var.Canonical
288+optimizePotentialTailCall def =
499−forwardApply =
289+ case def of
500− Var.inCore "Basics" "|>"
290+ Can.Def (A.At _ name) args expr ->
291+ do (argNames, defss) <- destructArgs args
292+ toTailDef name argNames defss <$>
293+ optimizeTailExpr name argNames expr
501
294
295+ Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
296+ do (argNames, defss) <- destructArgs (map fst typedArgs)
297+ toTailDef name argNames defss <$>
298+ optimizeTailExpr name argNames expr
502
299
503−-- right-associative (g <| (f <| x))
504−backwardApply :: Var.Canonical
505−backwardApply =
506− Var.inCore "Basics" "<|"
507
300
301+optimizeTailExpr :: N.Name -> [N.Name] -> Can.Expr -> Names.Tracker Opt.Expr
302+optimizeTailExpr name argNames locExpr@(A.At _ expression) =
303+ case expression of
304+ Can.Call (A.At _ (Can.VarTopLevel _ funcName)) args ->
305+ if funcName == name && length args == length argNames then
306+ Opt.TailCall name argNames <$> traverse optimizeExpr args
307+ else
308+ optimizeExpr locExpr
508
309
509−-- left-associative ((f >> g) >> h)
310+ Can.If branches finally ->
510−forwardCompose :: Var.Canonical
311+ let
511−forwardCompose =
312+ optimizeBranch (condition, branch) =
512− Var.inCore "Basics" ">>"
313+ (,)
314+ <$> optimizeExpr condition
315+ <*> optimizeTailExpr name argNames branch
316+ in
317+ Opt.If
318+ <$> traverse optimizeBranch branches
319+ <*> optimizeTailExpr name argNames finally
320+
321+ Can.Let def body ->
322+ optimizeDef def =<< optimizeTailExpr name argNames body
323+
324+ Can.LetRec defs body ->
325+ case defs of
326+ [def] ->
327+ Opt.Let
328+ <$> optimizePotentialTailCall def
329+ <*> optimizeTailExpr name argNames body
330+
331+ _ ->
332+ do obody <- optimizeTailExpr name argNames body
333+ foldM (\bod def -> optimizeDef def bod) obody defs
334+
335+ Can.LetDestruct pattern expr body ->
336+ do (dname, defs) <- destruct pattern
337+ oexpr <- optimizeExpr expr
338+ obody <- optimizeTailExpr dname argNames body
339+ pure $
340+ Opt.Let (Opt.Def dname oexpr) (foldr Opt.Let obody defs)
513
341
342+ Can.Case expr branches ->
343+ error "TODO"
514
344
515−-- right-associative (h << (g << f))
345+ _ ->
516−backwardCompose :: Var.Canonical
346+ optimizeExpr locExpr
517−backwardCompose =
518− Var.inCore "Basics" "<<"
519
347
520
348
521−cons :: Var.Canonical
522−cons =
523− Var.Canonical Var.BuiltIn "::"
524
349
350+-- DETECT TAIL CALLS
525
351
526−type Assoc =
527− Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)
528
352
353+toTailDef :: N.Name -> [N.Name] -> [[Opt.Def]] -> Opt.Expr -> Opt.Def
354+toTailDef name argNames defss body =
355+ if hasTailCall body then
356+ Opt.TailDef name argNames (foldr Opt.Let body (concat defss))
357+ else
358+ Opt.Def name (Opt.Function argNames (foldr Opt.Let body (concat defss)))
529
359
530−left :: Assoc
531−left =
532− flip (,)
533
360
361+hasTailCall :: Opt.Expr -> Bool
362+hasTailCall expression =
363+ case expression of
364+ Opt.TailCall _ _ _ ->
365+ True
534
366
535−right :: Assoc
367+ Opt.If branches finally ->
536−right =
368+ hasTailCall finally || any (hasTailCall . snd) branches
537− (,)
538
369
370+ Opt.Let _ body ->
371+ hasTailCall body
539
372
540−collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr
373+ Opt.Case _ _ branches ->
541−collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =
374+ any (hasTailCall . snd) branches
542− case expr of
543− Can.Binop op leftExpr rightExpr | op == desiredOp ->
544− let
545− (func, arg) = assoc leftExpr rightExpr
546− in
547− A.A ann (Can.App func (collect makeRoot assoc desiredOp arg))
548
375
549 _ ->
376 _ ->
550− makeRoot annExpr
377+ False
551−
552−
553−makeOptBinop :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Env.Optimizer Opt.Expr
554−makeOptBinop (Var.Canonical home op) leftExpr rightExpr =
555− case home of
556− Var.Local ->
557− error "bug manifesting in Optimize.makeOptBinop"
558−
559− Var.BuiltIn ->
560− error "bug manifesting in Optimize.makeOptBinop"
561−
562− Var.Module name ->
563− do let var = Var.Global name op
564− Env.register var
565− return $ Opt.Binop var leftExpr rightExpr
566
378
567− Var.TopLevel name ->
568− do let var = Var.Global name op
569− Env.register var
570− return $ Opt.Binop var leftExpr rightExpr
src/Optimize/DecisionTree.hs+224−159
@@ -1,5 +1,13 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−module Optimize.DecisionTree where
3+module Optimize.DecisionTree
4+ ( compile
5+ , Path(..)
6+ , Test(..)
7+ )
8+ where
9+
10+
3{- To learn more about how this works, definitely read through:
11{- To learn more about how this works, definitely read through:
4
12
5 "When Do Match-Compilation Heuristics Matter?"
13 "When Do Match-Compilation Heuristics Matter?"
@@ -12,24 +20,18 @@ as SML/NJ to get nice trees.
12-}
20-}
13
21
14import Control.Arrow (second)
22import Control.Arrow (second)
23+import Control.Monad (liftM, liftM2)
15import Data.Binary
24import Data.Binary
16import qualified Data.List as List
25import qualified Data.List as List
17−import qualified Data.Map as Map
18−import qualified Data.Set as Set
19import qualified Data.Maybe as Maybe
26import qualified Data.Maybe as Maybe
20−import qualified Data.Text as Text
27+import qualified Data.Set as Set
21import Data.Text (Text)
28import Data.Text (Text)
22
29
23−import qualified AST.Helpers as Help
30+import qualified AST.Canonical as Can
24−import qualified AST.Literal as L
31+import qualified Elm.Name as N
25−import qualified AST.Pattern as P
26−import qualified AST.Variable as Var
27import qualified Reporting.Annotation as A
32import qualified Reporting.Annotation as A
28
33
29
34
30−type CPattern = P.Canonical
31−
32−
33
35
34-- COMPILE CASES
36-- COMPILE CASES
35
37
@@ -43,30 +45,13 @@ If 2 or more leaves point to the same label, we need to do some tricks in JS to
43make that work nicely. When is JS getting goto?! ;) That is outside the scope
45make that work nicely. When is JS getting goto?! ;) That is outside the scope
44of this module though.
46of this module though.
45-}
47-}
46−compile :: VariantDict -> [(CPattern, Int)] -> DecisionTree
48+compile :: [(Can.Pattern, Int)] -> DecisionTree
47−compile variantDict rawBranches =
49+compile rawBranches =
48 let
50 let
49 format (pattern, index) =
51 format (pattern, index) =
50 Branch index [(Empty, pattern)]
52 Branch index [(Empty, pattern)]
51 in
53 in
52− toDecisionTree variantDict (map format rawBranches)
54+ toDecisionTree (map format rawBranches)
53−
54−
55−{-| When a certain union type is defined, you specify a certain number of tags.
56−This helps us do a few optimizations:
57−
58− * If there is only one possible tag, we can always skip checking what it is.
59− Tuples are a common example of this.
60− * If we use all possible tags, we can skip doing the last test. If we have
61− checked N-1 of N tags, there is no need to test the Nth, we know its the
62− one we want
63−
64−So this dictionary maps tags to the number of variants that exist, so it'll
65−contain things like [ ("Just", 2), ("Nothing", 2), ("#2", 1), ... ] which
66−we can use for these optimizations.
67−-}
68−type VariantDict =
69− Map.Map Var.Home (Map.Map Text Int)
70
55
71
56
72
57
@@ -74,27 +59,29 @@ type VariantDict =
74
59
75
60
76data DecisionTree
61data DecisionTree
77− = Match Int
62+ = Match Int
78− | Decision
63+ | Decision
79− { _test :: Path
64+ { _path :: Path
80− , _edges :: [(Test, DecisionTree)]
65+ , _edges :: [(Test, DecisionTree)]
81− , _default :: Maybe DecisionTree
66+ , _default :: Maybe DecisionTree
82− }
67+ }
83− deriving (Eq)
68+ deriving (Eq)
84
69
85
70
86data Test
71data Test
87− = Constructor Var.Canonical
72+ = IsCtor Int N.Name
88− | Literal L.Literal
73+ | IsInt Int
74+ | IsChr Text
75+ | IsStr Text
89− deriving (Eq, Ord)
76+ deriving (Eq, Ord)
90
77
91
78
92data Path
79data Path
93− = Position Int Path
80+ = Index Int Path
94− | Field Text Path
81+ | Field N.Name Path
95− | Empty
82+ | Empty
96− | Alias
83+ | Alias
97− deriving (Eq)
84+ deriving (Eq)
98
85
99
86
100
87
@@ -110,17 +97,17 @@ add path finalLink =
110 Alias ->
97 Alias ->
111 error "nothing should be added to an alias path"
98 error "nothing should be added to an alias path"
112
99
113− Position index subpath ->
100+ Index index subpath ->
114− Position index (add subpath finalLink)
101+ Index index (add subpath finalLink)
115
102
116 Field name subpath ->
103 Field name subpath ->
117 Field name (add subpath finalLink)
104 Field name (add subpath finalLink)
118
105
119
106
120−subPositions :: Path -> [CPattern] -> [(Path, CPattern)]
107+subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]
121subPositions path patterns =
108subPositions path patterns =
122 zipWith
109 zipWith
123− (\index pattern -> (add path (Position index Empty), pattern))
110+ (\index pattern -> (add path (Index index Empty), pattern))
124 [0..]
111 [0..]
125 patterns
112 patterns
126
113
@@ -132,15 +119,15 @@ subPositions path patterns =
132data Branch =
119data Branch =
133 Branch
120 Branch
134 { _goal :: Int
121 { _goal :: Int
135− , _patterns :: [(Path, CPattern)]
122+ , _patterns :: [(Path, Can.Pattern)]
136 }
123 }
137
124
138
125
139−toDecisionTree :: VariantDict -> [Branch] -> DecisionTree
126+toDecisionTree :: [Branch] -> DecisionTree
140−toDecisionTree variantDict rawBranches =
127+toDecisionTree rawBranches =
141 let
128 let
142 branches =
129 branches =
143− map (flattenPatterns variantDict) rawBranches
130+ map flattenPatterns rawBranches
144 in
131 in
145 case checkForMatch branches of
132 case checkForMatch branches of
146 Just goal ->
133 Just goal ->
@@ -149,13 +136,13 @@ toDecisionTree variantDict rawBranches =
149 Nothing ->
136 Nothing ->
150 let
137 let
151 path =
138 path =
152− pickPath variantDict branches
139+ pickPath branches
153
140
154 (edges, fallback) =
141 (edges, fallback) =
155− gatherEdges variantDict branches path
142+ gatherEdges branches path
156
143
157 decisionEdges =
144 decisionEdges =
158− map (second (toDecisionTree variantDict)) edges
145+ map (second toDecisionTree) edges
159 in
146 in
160 case (decisionEdges, fallback) of
147 case (decisionEdges, fallback) of
161 ([(_tag, decisionTree)], []) ->
148 ([(_tag, decisionTree)], []) ->
@@ -165,41 +152,22 @@ toDecisionTree variantDict rawBranches =
165 Decision path decisionEdges Nothing
152 Decision path decisionEdges Nothing
166
153
167 ([], _ : _) ->
154 ([], _ : _) ->
168− toDecisionTree variantDict fallback
155+ toDecisionTree fallback
169
156
170 (_, _) ->
157 (_, _) ->
171− Decision path decisionEdges (Just (toDecisionTree variantDict fallback))
158+ Decision path decisionEdges (Just (toDecisionTree fallback))
172
159
173
160
174−isComplete :: VariantDict -> [Test] -> Bool
161+isComplete :: [Test] -> Bool
175−isComplete variantDict tests =
162+isComplete tests =
176 case head tests of
163 case head tests of
177− Constructor var ->
164+ IsCtor alts _ ->
178− getArity variantDict var == length tests
165+ alts == length tests
179−
180− Literal (L.Boolean _) ->
181− length tests == 2
182
166
183 _ ->
167 _ ->
184 False
168 False
185
169
186
170
187−getArity :: VariantDict -> Var.Canonical -> Int
188−getArity variantDict (Var.Canonical home name) =
189− case Map.lookup name =<< Map.lookup home variantDict of
190− Just arity ->
191− arity
192−
193− Nothing ->
194− if Help.isTuple name then
195− read (drop 6 (Text.unpack name))
196−
197− else
198− error
199− "Since the Optimize phase happens after canonicalization and type \
200− \inference, it is impossible that a pattern cannot be found."
201−
202−
203
171
204-- FLATTEN PATTERNS
172-- FLATTEN PATTERNS
205
173
@@ -207,38 +175,63 @@ getArity variantDict (Var.Canonical home name) =
207{-| Flatten type aliases and use the VariantDict to figure out when a tag is
175{-| Flatten type aliases and use the VariantDict to figure out when a tag is
208the only variant so we can skip doing any tests on it.
176the only variant so we can skip doing any tests on it.
209-}
177-}
210−flattenPatterns :: VariantDict -> Branch -> Branch
178+flattenPatterns :: Branch -> Branch
211−flattenPatterns variantDict (Branch goal pathPatterns) =
179+flattenPatterns (Branch goal pathPatterns) =
212− Branch goal (concatMap (flatten variantDict) pathPatterns)
180+ Branch goal (concatMap flatten pathPatterns)
213
181
214
182
215−flatten :: VariantDict -> (Path, CPattern) -> [(Path, CPattern)]
183+flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)]
216−flatten variantDict pathPattern@(path, A.A ann pattern) =
184+flatten pathPattern@(path, A.At region pattern) =
217 case pattern of
185 case pattern of
218− P.Var _ ->
186+ Can.PVar _ ->
219 [pathPattern]
187 [pathPattern]
220
188
221− P.Anything ->
189+ Can.PAnything ->
222 [pathPattern]
190 [pathPattern]
223
191
224− P.Alias alias realPattern ->
192+ Can.PAlias realPattern alias ->
225− (add path Alias, A.A ann (P.Var alias))
193+ (add path Alias, A.At region (Can.PVar alias))
226 :
194 :
227− flatten variantDict (path, realPattern)
195+ flatten (path, realPattern)
196+
197+ Can.PRecord _ ->
198+ [pathPattern]
228
199
229− P.Record _ ->
200+ Can.PUnit ->
230 [pathPattern]
201 [pathPattern]
231
202
232− P.Ctor tag patterns ->
203+ Can.PTuple a b Nothing ->
233− if getArity variantDict tag == 1 then
234− concatMap (flatten variantDict) (subPositions path patterns)
204+ concatMap flatten (subPositions path [a,b])
235
205
206+ Can.PTuple a b (Just c) ->
207+ concatMap flatten (subPositions path [a,b,c])
208+
209+ Can.PCtor _ _ _ (Can.CtorAlts numAlts _) _ args ->
210+ if numAlts == 1 then
211+ concatMap flatten (subPositions path (map dearg args))
236 else
212 else
237− [pathPattern]
213+ [pathPattern]
238
214
239− P.Literal _ ->
215+ Can.PList _ ->
240 [pathPattern]
216 [pathPattern]
241
217
218+ Can.PCons _ _ ->
219+ [pathPattern]
220+
221+ Can.PChr _ ->
222+ [pathPattern]
223+
224+ Can.PStr _ ->
225+ [pathPattern]
226+
227+ Can.PInt _ ->
228+ [pathPattern]
229+
230+
231+dearg :: Can.PatternCtorArg -> Can.Pattern
232+dearg (Can.PatternCtorArg _ _ pattern) =
233+ pattern
234+
242
235
243
236
244-- SUCCESSFULLY MATCH
237-- SUCCESSFULLY MATCH
@@ -263,8 +256,8 @@ checkForMatch branches =
263-- GATHER OUTGOING EDGES
256-- GATHER OUTGOING EDGES
264
257
265
258
266−gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])
259+gatherEdges :: [Branch] -> Path -> ([(Test, [Branch])], [Branch])
267−gatherEdges variantDict branches path =
260+gatherEdges branches path =
268 let
261 let
269 relevantTests =
262 relevantTests =
270 testsAtPath path branches
263 testsAtPath path branches
@@ -273,7 +266,7 @@ gatherEdges variantDict branches path =
273 map (edgesFor path branches) relevantTests
266 map (edgesFor path branches) relevantTests
274
267
275 fallbacks =
268 fallbacks =
276− if isComplete variantDict relevantTests then
269+ if isComplete relevantTests then
277 []
270 []
278 else
271 else
279 filter (isIrrelevantTo path) branches
272 filter (isIrrelevantTo path) branches
@@ -308,26 +301,57 @@ testAtPath selectedPath (Branch _ pathPatterns) =
308 Nothing ->
301 Nothing ->
309 Nothing
302 Nothing
310
303
311− Just (A.A _ pattern) ->
304+ Just (A.At _ pattern) ->
312 case pattern of
305 case pattern of
313− P.Ctor name _ ->
306+ Can.PCtor _ _ _ (Can.CtorAlts numAlts _) name _ ->
314− Just (Constructor name)
307+ Just (IsCtor numAlts name)
308+
309+ Can.PInt int ->
310+ Just (IsInt int)
311+
312+ Can.PStr str ->
313+ Just (IsStr str)
315
314
316− P.Literal lit ->
315+ Can.PChr chr ->
317− Just (Literal lit)
316+ Just (IsChr chr)
318
317
319− P.Var _ ->
318+ Can.PList [] ->
319+ Just nilTest
320+
321+ Can.PList _ ->
322+ Just consTest
323+
324+ Can.PCons _ _ ->
325+ Just consTest
326+
327+ Can.PVar _ ->
320 Nothing
328 Nothing
321
329
322− P.Alias _ _ ->
330+ Can.PAlias _ _ ->
323 error "aliases should never reach 'testAtPath' function"
331 error "aliases should never reach 'testAtPath' function"
324
332
325− P.Anything ->
333+ Can.PAnything ->
326 Nothing
334 Nothing
327
335
328− P.Record _ ->
336+ Can.PUnit ->
329 Nothing
337 Nothing
330
338
339+ Can.PTuple _ _ _ ->
340+ Nothing
341+
342+ Can.PRecord _ ->
343+ Nothing
344+
345+
346+{-# NOINLINE nilTest #-}
347+nilTest :: Test
348+nilTest = IsCtor 2 "[]"
349+
350+
351+{-# NOINLINE consTest #-}
352+consTest :: Test
353+consTest = IsCtor 2 "::"
354+
331
355
332
356
333-- BUILD EDGES
357-- BUILD EDGES
@@ -343,19 +367,48 @@ edgesFor path branches test =
343toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
367toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
344toRelevantBranch test path branch@(Branch goal pathPatterns) =
368toRelevantBranch test path branch@(Branch goal pathPatterns) =
345 case extract path pathPatterns of
369 case extract path pathPatterns of
346− Just (start, A.A _ pattern, end) ->
370+ Just (start, A.At region pattern, end) ->
347 case pattern of
371 case pattern of
348− P.Ctor name patterns ->
372+ Can.PCtor _ _ _ (Can.CtorAlts numAlts _) name args ->
349− if test == Constructor name then
373+ if test == IsCtor numAlts name then
350− Just (Branch goal (start ++ subPositions path patterns ++ end))
374+ Just (Branch goal (start ++ subPositions path (map dearg args) ++ end))
375+ else
376+ Nothing
377+
378+ Can.PList [] ->
379+ if test == IsCtor 2 "[]" then
380+ Just (Branch goal (start ++ end))
381+ else
382+ Nothing
383+
384+ Can.PList (hd:tl) ->
385+ if test == IsCtor 2 "::" then
386+ let tl' = A.At region (Can.PList tl) in
387+ Just (Branch goal (start ++ subPositions path [ hd, tl' ] ++ end))
388+ else
389+ Nothing
390+
391+ Can.PCons hd tl ->
392+ if test == IsCtor 2 "::" then
393+ Just (Branch goal (start ++ subPositions path [hd,tl] ++ end))
394+ else
395+ Nothing
351
396
397+ Can.PChr chr ->
398+ if test == IsChr chr then
399+ Just (Branch goal (start ++ end))
352 else
400 else
353 Nothing
401 Nothing
354
402
355− P.Literal lit ->
403+ Can.PStr str ->
356− if test == Literal lit then
404+ if test == IsStr str then
357 Just (Branch goal (start ++ end))
405 Just (Branch goal (start ++ end))
406+ else
407+ Nothing
358
408
409+ Can.PInt int ->
410+ if test == IsInt int then
411+ Just (Branch goal (start ++ end))
359 else
412 else
360 Nothing
413 Nothing
361
414
@@ -368,8 +421,8 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =
368
421
369extract
422extract
370 :: Path
423 :: Path
371− -> [(Path, CPattern)]
424+ -> [(Path, Can.Pattern)]
372− -> Maybe ([(Path, CPattern)], CPattern, [(Path, CPattern)])
425+ -> Maybe ([(Path, Can.Pattern)], Can.Pattern, [(Path, Can.Pattern)])
373extract selectedPath pathPatterns =
426extract selectedPath pathPatterns =
374 case pathPatterns of
427 case pathPatterns of
375 [] ->
428 [] ->
@@ -402,25 +455,43 @@ isIrrelevantTo selectedPath (Branch _ pathPatterns) =
402 not (needsTests pattern)
455 not (needsTests pattern)
403
456
404
457
405−needsTests :: CPattern -> Bool
458+needsTests :: Can.Pattern -> Bool
406−needsTests (A.A _ pattern) =
459+needsTests (A.At _ pattern) =
407 case pattern of
460 case pattern of
408− P.Var _ ->
461+ Can.PVar _ ->
409 False
462 False
410
463
411− P.Anything ->
464+ Can.PAnything ->
412 False
465 False
413
466
414− P.Alias _ _ ->
467+ Can.PAlias _ _ ->
415 error "aliases should never reach 'isIrrelevantTo' function"
468 error "aliases should never reach 'isIrrelevantTo' function"
416
469
417− P.Record _ ->
470+ Can.PRecord _ ->
471+ False
472+
473+ Can.PCtor _ _ _ _ _ _ ->
474+ True
475+
476+ Can.PList _ ->
477+ True
478+
479+ Can.PCons _ _ ->
480+ True
481+
482+ Can.PUnit ->
483+ False
484+
485+ Can.PTuple _ _ _ ->
418 False
486 False
419
487
420− P.Ctor _ _ ->
488+ Can.PChr _ ->
489+ True
490+
491+ Can.PStr _ ->
421 True
492 True
422
493
423− P.Literal _ ->
494+ Can.PInt _ ->
424 True
495 True
425
496
426
497
@@ -428,8 +499,8 @@ needsTests (A.A _ pattern) =
428-- PICK A PATH
499-- PICK A PATH
429
500
430
501
431−pickPath :: VariantDict -> [Branch] -> Path
502+pickPath :: [Branch] -> Path
432−pickPath variantDict branches =
503+pickPath branches =
433 let
504 let
434 allPaths =
505 allPaths =
435 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
506 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
@@ -439,10 +510,10 @@ pickPath variantDict branches =
439 path
510 path
440
511
441 tiedPaths ->
512 tiedPaths ->
442− head (bests (addWeights (smallBranchingFactor variantDict branches) tiedPaths))
513+ head (bests (addWeights (smallBranchingFactor branches) tiedPaths))
443
514
444
515
445−isChoicePath :: (Path, CPattern) -> Maybe Path
516+isChoicePath :: (Path, Can.Pattern) -> Maybe Path
446isChoicePath (path, pattern) =
517isChoicePath (path, pattern) =
447 if needsTests pattern then
518 if needsTests pattern then
448 Just path
519 Just path
@@ -485,11 +556,11 @@ smallDefaults branches path =
485 length (filter (isIrrelevantTo path) branches)
556 length (filter (isIrrelevantTo path) branches)
486
557
487
558
488−smallBranchingFactor :: VariantDict -> [Branch] -> Path -> Int
559+smallBranchingFactor :: [Branch] -> Path -> Int
489−smallBranchingFactor variantDict branches path =
560+smallBranchingFactor branches path =
490 let
561 let
491 (edges, fallback) =
562 (edges, fallback) =
492− gatherEdges variantDict branches path
563+ gatherEdges branches path
493 in
564 in
494 length edges + (if null fallback then 0 else 1)
565 length edges + (if null fallback then 0 else 1)
495
566
@@ -499,42 +570,36 @@ smallBranchingFactor variantDict branches path =
499
570
500
571
501instance Binary Test where
572instance Binary Test where
573+ put test =
574+ case test of
575+ IsCtor a b -> putWord8 0 >> put a >> put b
576+ IsChr a -> putWord8 1 >> put a
577+ IsStr a -> putWord8 2 >> put a
578+ IsInt a -> putWord8 3 >> put a
579+
502 get =
580 get =
503 do word <- getWord8
581 do word <- getWord8
504 case word of
582 case word of
505− 0 -> Constructor <$> get
583+ 0 -> liftM2 IsCtor get get
506− 1 -> Literal <$> get
584+ 1 -> liftM IsChr get
585+ 2 -> liftM IsStr get
586+ 3 -> liftM IsInt get
507 _ -> error "problem getting DecisionTree.Test binary"
587 _ -> error "problem getting DecisionTree.Test binary"
508
588
509− put test =
510− case test of
511− Constructor var ->
512− putWord8 0 >> put var
513−
514− Literal literal ->
515− putWord8 1 >> put literal
516−
517
589
518instance Binary Path where
590instance Binary Path where
591+ put path =
592+ case path of
593+ Index a b -> putWord8 0 >> put a >> put b
594+ Field a b -> putWord8 1 >> put a >> put b
595+ Empty -> putWord8 2
596+ Alias -> putWord8 3
597+
519 get =
598 get =
520 do word <- getWord8
599 do word <- getWord8
521 case word of
600 case word of
522− 0 -> Position <$> get <*> get
601+ 0 -> liftM2 Index get get
523− 1 -> Field <$> get <*> get
602+ 1 -> liftM2 Field get get
524 2 -> pure Empty
603 2 -> pure Empty
525 3 -> pure Alias
604 3 -> pure Alias
526 _ -> error "problem getting DecisionTree.Path binary"
605 _ -> error "problem getting DecisionTree.Path binary"
527−
528− put path =
529− case path of
530− Position index rest ->
531− putWord8 0 >> put index >> put rest
532−
533− Field field rest ->
534− putWord8 1 >> put field >> put rest
535−
536− Empty ->
537− putWord8 2
538−
539− Alias ->
540− putWord8 3
src/Optimize/Environment.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Optimize.Environment
4− ( Optimizer, run
5− , Env
6− , getVariantDict
7− , getHome
8− , getTailCall, setTailCall
9− , freshName
10− , register
11− , registerEffects
12− , indirectly
13− )
14− where
15−
16−import qualified Control.Monad.State.Strict as State
17−import Data.Monoid ((<>))
18−import qualified Data.Set as Set
19−import qualified Data.Text as Text
20−import Data.Text (Text)
21−
22−import qualified AST.Effects as Effects
23−import qualified AST.Expression.Optimized as Opt
24−import qualified AST.Module.Name as ModuleName
25−import qualified AST.Variable as Var
26−import qualified Optimize.DecisionTree as DT
27−
28−
29−
30−-- ENVIRONMENT
31−
32−
33−data Env =
34− Env
35− { _read_only_variants :: !DT.VariantDict
36− , _read_only_home :: !ModuleName.Canonical
37− , _uid :: !Int
38− , _deps :: Deps
39− , _effects :: Maybe Effects.ManagerType
40− , _has_tail_call :: !Bool
41− }
42−
43−
44−
45−-- DEPS
46−
47−
48−data Deps
49− = Direct { _direct :: Set.Set Var.Global, _indirect :: Set.Set Var.Global }
50− | Indirect (Set.Set Var.Global)
51−
52−
53−emptyDeps :: Deps
54−emptyDeps =
55− Direct Set.empty Set.empty
56−
57−
58−insertDep :: Var.Global -> Deps -> Deps
59−insertDep var deps =
60− case deps of
61− Direct direct indirect ->
62− Direct (Set.insert var direct) indirect
63−
64− Indirect indirect ->
65− Indirect (Set.insert var indirect)
66−
67−
68−unionDeps :: Set.Set Var.Global -> Deps -> Deps
69−unionDeps vars deps =
70− case deps of
71− Direct direct indirect ->
72− Direct (Set.union vars direct) indirect
73−
74− Indirect indirect ->
75− Indirect (Set.union vars indirect)
76−
77−
78−
79−-- OPTIMIZER
80−
81−
82−type Optimizer a =
83− State.State Env a
84−
85−
86−run
87− :: DT.VariantDict
88− -> ModuleName.Canonical
89− -> Optimizer (Text, Opt.Def)
90− -> (Text, Opt.Decl)
91−run variantDict home optimizer =
92− let
93− ((name, def), Env _ _ _ (Direct direct indirect) fx _) =
94− State.runState optimizer $
95− Env variantDict home 0 emptyDeps Nothing False
96− in
97− ( name, Opt.Decl direct indirect fx def )
98−
99−
100−
101−-- READ ONLY
102−
103−
104−getVariantDict :: Optimizer DT.VariantDict
105−getVariantDict =
106− State.gets _read_only_variants
107−
108−
109−getHome :: Optimizer ModuleName.Canonical
110−getHome =
111− State.gets _read_only_home
112−
113−
114−
115−-- TAIL CALLS
116−
117−
118−getTailCall :: Optimizer Bool
119−getTailCall =
120− State.gets _has_tail_call
121−
122−
123−setTailCall :: Bool -> Optimizer ()
124−setTailCall bool =
125− do env <- State.get
126− State.put (env { _has_tail_call = bool })
127−
128−
129−
130−-- FRESH VARIABLES
131−
132−
133−freshName :: Optimizer Text
134−freshName =
135− do (Env vs home uid deps fx htc) <- State.get
136− State.put (Env vs home (uid + 1) deps fx htc)
137− return ("_p" <> Text.pack (show uid))
138−
139−
140−
141−-- REGISTER DEPENDENCIES
142−
143−
144−register :: Var.Global -> Optimizer ()
145−register global =
146− State.modify' (registerHelp global)
147−
148−
149−registerHelp :: Var.Global -> Env -> Env
150−registerHelp dep (Env vs home uid deps fx htc) =
151− Env vs home uid (insertDep dep deps) fx htc
152−
153−
154−indirectly :: Optimizer a -> Optimizer a
155−indirectly optimizer =
156− do (Env vs home uid deps fx htc) <- State.get
157− case deps of
158− Indirect _ ->
159− optimizer
160−
161− Direct direct indirect ->
162− do State.put (Env vs home uid (Indirect indirect) fx htc)
163− result <- optimizer
164− (Env vs_ home_ uid_ (Indirect indirect_) fx_ htc_) <- State.get
165− State.put (Env vs_ home_ uid_ (Direct direct indirect_) fx_ htc_)
166− return result
167−
168−
169−
170−-- REGISTER EFFECTS
171−
172−
173−registerEffects :: ModuleName.Canonical -> Effects.ManagerType -> Optimizer Effects.ManagerType
174−registerEffects home manager =
175− do (Env vs hm uid deps _ htc) <- State.get
176− let newDeps = unionDeps (getEffectDeps home manager) deps
177− State.put (Env vs hm uid newDeps (Just manager) htc)
178− return manager
179−
180−
181−getEffectDeps :: ModuleName.Canonical -> Effects.ManagerType -> Set.Set Var.Global
182−getEffectDeps home manager =
183− Set.fromList $ map (Var.Global home) $
184− case manager of
185− Effects.Cmds ->
186− [ "init", "onEffects", "onSelfMsg", "cmdMap" ]
187−
188− Effects.Subs ->
189− [ "init", "onEffects", "onSelfMsg", "subMap" ]
190−
191− Effects.Both ->
192− [ "init", "onEffects", "onSelfMsg", "cmdMap", "subMap" ]
src/Optimize/Inline.hsdeleted−283
@@ -1,283 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Optimize.Inline (inline) where
4−
5−import Control.Arrow (second, (***))
6−import Control.Monad (foldM)
7−import qualified Data.List as List
8−import qualified Data.Map as Map
9−import Data.Text (Text)
10−
11−import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))
12−import qualified AST.Expression.Optimized as Opt
13−import qualified Optimize.Environment as Env
14−
15−
16−
17−inline :: Map.Map Text Opt.Expr -> Opt.Expr -> Env.Optimizer Opt.Expr
18−inline rawSubs expression =
19− let
20− counts =
21− count expression
22−
23− annotatedSubs =
24− Map.toList (Map.intersectionWith (,) counts rawSubs)
25− in
26− do (Subs subs defs) <- foldM processSubs (Subs Map.empty []) annotatedSubs
27− let inlinedExpr = replace subs expression
28− return $
29− if null defs then
30− inlinedExpr
31−
32− else
33− Let (map (second Opt.Def) defs) inlinedExpr
34−
35−
36−data Subs =
37− Subs
38− { _substitutions :: Map.Map Text Opt.Expr
39− , _definitions :: [(Text, Opt.Expr)]
40− }
41−
42−
43−processSubs :: Subs -> (Text, (Int, Opt.Expr)) -> Env.Optimizer Subs
44−processSubs (Subs subs defs) (name, (n, expr)) =
45− if n == 1 then
46− return $ Subs (Map.insert name expr subs) defs
47−
48− else
49− do uniqueName <- Env.freshName
50− return $ Subs
51− (Map.insert name (Opt.VarLocal uniqueName) subs)
52− ((uniqueName, expr) : defs)
53−
54−
55−
56−-- HELPERS
57−
58−
59−deleteBatch :: [Text] -> Map.Map Text a -> Map.Map Text a
60−deleteBatch names dict =
61− List.foldl' (flip Map.delete) dict names
62−
63−
64−
65−-- COUNT VARIABLE APPEARANCES
66−
67−
68−count :: Opt.Expr -> Map.Map Text Int
69−count expression =
70− let
71− count2 a b =
72− Map.unionWith (+) (count a) (count b)
73−
74− countMany xs =
75− Map.unionsWith (+) (map count xs)
76− in
77− case expression of
78− Literal _ ->
79− Map.empty
80−
81− VarLocal name ->
82− Map.singleton name 1
83−
84− VarGlobal _ ->
85− Map.empty
86−
87− List exprs ->
88− countMany exprs
89−
90− Binop _ left right ->
91− count2 left right
92−
93− Function args body ->
94− deleteBatch args (count body)
95−
96− Call func args ->
97− Map.unionWith (+) (count func) (countMany args)
98−
99− TailCall _name _argNames args ->
100− countMany args
101−
102− If branches finally ->
103− Map.unionsWith (+) (count finally : map (uncurry count2) branches)
104−
105− Let defs expr ->
106− let
107− countDef (name, def) =
108− case def of
109− Opt.Def body ->
110− Map.delete name (count body)
111−
112− Opt.TailDef argNames body ->
113− deleteBatch (name:argNames) (count body)
114−
115− exprCount =
116− deleteBatch (map fst defs) (count expr)
117− in
118− Map.unionsWith (+) (exprCount : map countDef defs)
119−
120− Case _ decider jumps ->
121− let
122− countDecider dcdr =
123− case dcdr of
124− Leaf (Inline expr) ->
125− count expr
126−
127− Leaf (Jump _) ->
128− Map.empty
129−
130− Chain _ success failure ->
131− Map.unionWith (+) (countDecider success) (countDecider failure)
132−
133− FanOut _path tests fallback ->
134− Map.unionsWith (+) (map countDecider (fallback : map snd tests))
135− in
136− Map.unionsWith (+) (countDecider decider : map (count . snd) jumps)
137−
138− Ctor _tag values ->
139− countMany values
140−
141− CtorAccess root _index ->
142− count root
143−
144− Access record _field ->
145− count record
146−
147− Update record fields ->
148− Map.unionWith (+) (count record) (countMany (map snd fields))
149−
150− Record fields ->
151− countMany (map snd fields)
152−
153− Cmd _ _ ->
154− Map.empty
155−
156− Sub _ _ ->
157− Map.empty
158−
159− OutgoingPort _ _ ->
160− Map.empty
161−
162− IncomingPort _ _ ->
163− Map.empty
164−
165− Program _ expr ->
166− count expr
167−
168− GLShader _ ->
169− Map.empty
170−
171− Crash _ _ maybeBranchProblem ->
172− maybe Map.empty count maybeBranchProblem
173−
174−
175−
176−-- REPLACE
177−
178−
179−replace :: Map.Map Text Opt.Expr -> Opt.Expr -> Opt.Expr
180−replace substitutions expression =
181− let
182− go = replace substitutions
183− in
184− case expression of
185− Literal _ ->
186− expression
187−
188− VarLocal name ->
189− maybe expression id (Map.lookup name substitutions)
190−
191− VarGlobal _ ->
192− expression
193−
194− List exprs ->
195− List (map go exprs)
196−
197− Binop op left right ->
198− Binop op (go left) (go right)
199−
200− Function args body ->
201− Function args (replace (deleteBatch args substitutions) body)
202−
203− Call func args ->
204− Call (go func) (map go args)
205−
206− TailCall name argNames args ->
207− TailCall name argNames (map go args)
208−
209− If branches finally ->
210− If (map (go *** go) branches) (go finally)
211−
212− Let defs expr ->
213− let
214− replaceDef (name, def) =
215− case def of
216− Opt.Def body ->
217− (,) name $ Opt.Def $
218− replace (Map.delete name substitutions) body
219−
220− Opt.TailDef argNames body ->
221− (,) name $ Opt.TailDef argNames $
222− replace (deleteBatch (name:argNames) substitutions) body
223−
224− boundNames =
225− map fst defs
226− in
227− Let
228− (map replaceDef defs)
229− (replace (deleteBatch boundNames substitutions) expr)
230−
231− Case exprName decider jumps ->
232− let
233− goDecider dcdr =
234− case dcdr of
235− Leaf (Inline expr) ->
236− Leaf (Inline (go expr))
237−
238− Leaf (Jump _target) ->
239− dcdr
240−
241− Chain chain success failure ->
242− Chain chain (goDecider success) (goDecider failure)
243−
244− FanOut path tests fallback ->
245− FanOut path (map (second goDecider) tests) (goDecider fallback)
246− in
247− Case exprName (goDecider decider) (map (second go) jumps)
248−
249− Ctor tag values ->
250− Ctor tag (map go values)
251−
252− CtorAccess root index ->
253− CtorAccess (go root) index
254−
255− Access record field ->
256− Access (go record) field
257−
258− Update record fields ->
259− Update (go record) (map (second go) fields)
260−
261− Record fields ->
262− Record (map (second go) fields)
263−
264− Cmd _ _ ->
265− expression
266−
267− Sub _ _ ->
268− expression
269−
270− OutgoingPort _ _ ->
271− expression
272−
273− IncomingPort _ _ ->
274− expression
275−
276− Program kind expr ->
277− Program kind (go expr)
278−
279− GLShader _ ->
280− expression
281−
282− Crash home region maybeBranchProblem ->
283− Crash home region (fmap go maybeBranchProblem)
src/Optimize/Names.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE Rank2Types #-}
4+module Optimize.Names
5+ ( Tracker
6+ , run
7+ , generate
8+ , registerKernel
9+ , registerGlobal
10+ )
11+ where
12+
13+
14+import Data.Monoid ((<>))
15+import qualified Data.Set as Set
16+import qualified Data.Text as Text
17+
18+import qualified AST.Optimized as Opt
19+import qualified AST.Module.Name as ModuleName
20+import qualified Elm.Name as N
21+
22+
23+
24+-- GENERATOR
25+
26+
27+newtype Tracker a =
28+ Tracker (
29+ forall r.
30+ Int
31+ -> Set.Set N.Name
32+ -> Set.Set Opt.Global
33+ -> (Int -> Set.Set N.Name -> Set.Set Opt.Global -> a -> r)
34+ -> r
35+ )
36+
37+
38+run :: Tracker a -> (Set.Set N.Name, Set.Set Opt.Global, a)
39+run (Tracker k) =
40+ k 0 Set.empty Set.empty
41+ (\_uid kernels globals value -> (kernels, globals, value))
42+
43+
44+generate :: Tracker N.Name
45+generate =
46+ Tracker $ \n k g ok ->
47+ ok (n + 1) k g ("_n" <> Text.pack (show n))
48+
49+
50+registerKernel :: N.Name -> a -> Tracker a
51+registerKernel name value =
52+ Tracker $ \n k g ok ->
53+ ok n (Set.insert name k) g value
54+
55+
56+registerGlobal :: ModuleName.Canonical -> N.Name -> Tracker Opt.Expr
57+registerGlobal home name =
58+ Tracker $ \n k g ok ->
59+ let global = Opt.Global home name in
60+ ok n k (Set.insert global g) (Opt.VarGlobal global)
61+
62+
63+
64+-- INSTANCES
65+
66+
67+instance Functor Tracker where
68+ fmap func (Tracker kv) =
69+ Tracker $ \n k g ok ->
70+ let
71+ ok1 n1 k1 g1 value =
72+ ok n1 k1 g1 (func value)
73+ in
74+ kv n k g ok1
75+
76+
77+instance Applicative Tracker where
78+ {-# INLINE pure #-}
79+ pure value =
80+ Tracker $ \n k g ok -> ok n k g value
81+
82+ (<*>) (Tracker kf) (Tracker kv) =
83+ Tracker $ \n0 k0 g0 ok ->
84+ let
85+ ok1 n1 k1 g1 func =
86+ let
87+ ok2 n2 k2 g2 value =
88+ ok n2 k2 g2 (func value)
89+ in
90+ kv n1 k1 g1 ok2
91+ in
92+ kf n0 k0 g0 ok1
93+
94+
95+instance Monad Tracker where
96+ return = pure
97+
98+ (>>=) (Tracker ka) callback =
99+ Tracker $ \n k g ok ->
100+ let
101+ ok1 n1 k1 g1 a =
102+ case callback a of
103+ Tracker kb -> kb n1 k1 g1 ok
104+ in
105+ ka n k g ok1