git.iko.soy/elk
on 966edcd help sign in
elk/src/Optimize.hs
400 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize
4 ( optimizeExpr
5 )
6 where
9import Control.Monad (foldM)
11import qualified AST.Canonical as Can
12import qualified AST.Optimized as Opt
13import qualified AST.Module.Name as ModuleName
14import qualified Data.Index as Index
15import qualified Elm.Name as N
16import qualified Optimize.Case as Case
17import qualified Optimize.Names as Names
18import qualified Reporting.Annotation as A
22-- OPTIMIZE
26-- EXPRESSIONS
29optimizeExpr :: Can.Expr -> Names.Tracker Opt.Expr
30optimizeExpr (A.At region expression) =
31 case expression of
32 Can.VarLocal name ->
33 pure (Opt.VarLocal name)
35 Can.VarTopLevel home name ->
36 Names.registerGlobal home name
38 Can.VarKernel home name ->
39 Names.registerKernel home (Opt.VarKernel home name)
41 Can.VarForeign home name _ ->
42 Names.registerGlobal home name
44 Can.VarDebug home name _ ->
45 Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)
47 Can.VarOperator _ home name _ ->
48 Names.registerGlobal home name
50 Can.Chr chr ->
51 pure (Opt.Chr chr)
53 Can.Str str ->
54 pure (Opt.Str str)
56 Can.Int int ->
57 pure (Opt.Int int)
59 Can.Float float ->
60 pure (Opt.Float float)
62 Can.List entries ->
63 Opt.List <$> traverse optimizeExpr entries
65 Can.Negate expr ->
66 do func <- Names.registerGlobal ModuleName.basics N.negate
67 arg <- optimizeExpr expr
68 pure $ Opt.Call func [arg]
70 Can.Binop _ home name _ left right ->
71 do optFunc <- Names.registerGlobal home name
72 optLeft <- optimizeExpr left
73 optRight <- optimizeExpr right
74 return (Opt.Call optFunc [optLeft, optRight])
76 Can.Lambda args body ->
77 do (argNames, defss) <- destructArgs args
78 obody <- optimizeExpr body
79 pure $ Opt.Function argNames (foldr Opt.Let obody (concat defss))
81 Can.Call func args ->
82 Opt.Call
83 <$> optimizeExpr func
84 <*> traverse optimizeExpr args
86 Can.If branches finally ->
87 let
88 optimizeBranch (condition, branch) =
89 (,)
90 <$> optimizeExpr condition
91 <*> optimizeExpr branch
92 in
93 Opt.If
94 <$> traverse optimizeBranch branches
95 <*> optimizeExpr finally
97 Can.Let def body ->
98 optimizeDef def =<< optimizeExpr body
100 Can.LetRec defs body ->
101 case defs of
102 [def] ->
103 Opt.Let
104 <$> optimizePotentialTailCall def
105 <*> optimizeExpr body
107 _ ->
108 do obody <- optimizeExpr body
109 foldM (\bod def -> optimizeDef def bod) obody defs
111 Can.LetDestruct pattern expr body ->
112 do (name, defs) <- destruct pattern
113 oexpr <- optimizeExpr expr
114 obody <- optimizeExpr body
115 pure $
116 Opt.Let (Opt.Def name oexpr) (foldr Opt.Let obody defs)
118 Can.Case expr branches ->
119 let
120 optimizeBranch root (Can.CaseBranch pattern branch) =
121 do defs <- destructHelp (Opt.VarLocal root) pattern []
122 obranch <- optimizeExpr branch
123 pure (pattern, foldr Opt.Let obranch defs)
124 in
125 do oexpr <- optimizeExpr expr
126 case oexpr of
127 Opt.VarLocal root ->
128 Case.optimize root <$> traverse (optimizeBranch root) branches
130 _ ->
131 do root <- Names.generate
132 Case.optimize root <$> traverse (optimizeBranch root) branches
134 Can.Accessor field ->
135 Names.registerField field (Opt.Accessor field)
137 Can.Access record field ->
138 do optRecord <- optimizeExpr record
139 Names.registerField field (Opt.Access optRecord field)
141 Can.Update record updates ->
142 Names.registerFields updates Opt.Update
143 <*> optimizeExpr record
144 <*> traverse optimizeExpr updates
146 Can.Record fields ->
147 Names.registerFields fields Opt.Record
148 <*> traverse optimizeExpr fields
150 Can.Unit ->
151 Names.registerKernel N.utils Opt.Unit
153 Can.Tuple a b maybeC ->
154 Names.registerKernel N.utils Opt.Tuple
155 <*> optimizeExpr a
156 <*> optimizeExpr b
157 <*> traverse optimizeExpr maybeC
159 Can.Shader _ src _ ->
160 pure (Opt.Shader src)
164-- DEFINITION
167optimizeDef :: Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr
168optimizeDef def body =
169 case def of
170 Can.Def (A.At _ name) args expr ->
171 optimizeDefHelp name args expr body
173 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
174 optimizeDefHelp name (map fst typedArgs) expr body
177optimizeDefHelp :: N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr
178optimizeDefHelp name args expr body =
179 case args of
180 [] ->
181 do oexpr <- optimizeExpr expr
182 pure $ Opt.Let (Opt.Def name oexpr) body
184 _ ->
185 do (argNames, defss) <- destructArgs args
186 let func = Opt.Function argNames (foldr Opt.Let body (concat defss))
187 pure $
188 Opt.Let (Opt.Def name func) body
192-- DESTRUCTURING
195destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [[Opt.Def]])
196destructArgs args =
197 unzip <$> traverse destruct args
200destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Def])
201destruct pattern@(A.At _ ptrn) =
202 case ptrn of
203 Can.PVar name ->
204 pure (name, [])
206 Can.PAlias subPattern name ->
207 do revDefs <- destructHelp (Opt.VarLocal name) subPattern []
208 pure (name, reverse revDefs)
210 _ ->
211 do name <- Names.generate
212 revDefs <- destructHelp (Opt.VarLocal name) pattern []
213 pure (name, reverse revDefs)
216destructHelp :: Opt.Expr -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
217destructHelp root (A.At region pattern) revDefs =
218 case pattern of
219 Can.PAnything ->
220 pure revDefs
222 Can.PVar name ->
223 pure (Opt.Def name root : revDefs)
225 Can.PRecord fields ->
226 let
227 addFieldDef defs name =
228 Names.registerField name $
229 Opt.Def name (Opt.Access root name) : defs
230 in
231 foldM addFieldDef revDefs fields
233 Can.PAlias subPattern name ->
234 destructHelp (Opt.VarLocal name) subPattern $
235 Opt.Def name root : revDefs
237 Can.PUnit ->
238 pure revDefs
240 Can.PTuple a b maybeC ->
241 do name <- Names.generate
242 let tuple = Opt.VarLocal name
243 let newRevDefs = Opt.Def name root : revDefs
244 case maybeC of
245 Nothing ->
246 destructHelp (Opt.CtorAccess tuple Index.second) b =<<
247 destructHelp (Opt.CtorAccess tuple Index.first) a newRevDefs
249 Just c ->
250 destructHelp (Opt.CtorAccess tuple Index.third) c =<<
251 destructHelp (Opt.CtorAccess tuple Index.second) b =<<
252 destructHelp (Opt.CtorAccess tuple Index.first) a newRevDefs
254 Can.PList [] ->
255 pure revDefs
257 Can.PList (hd:tl) ->
258 destructCons root hd (A.At region (Can.PList tl)) revDefs
260 Can.PCons hd tl ->
261 destructCons root hd tl revDefs
263 Can.PChr _ ->
264 pure revDefs
266 Can.PStr _ ->
267 pure revDefs
269 Can.PInt _ ->
270 pure revDefs
272 Can.PCtor _ _ _ _ _ args ->
273 do name <- Names.generate
274 foldM
275 (destructCtorArg (Opt.VarLocal name))
276 (Opt.Def name root : revDefs)
277 args
280destructCons :: Opt.Expr -> Can.Pattern -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
281destructCons root hd tl revDefs =
282 do name <- Names.generate
283 let list = Opt.VarLocal name
284 destructHelp (Opt.CtorAccess list Index.first) hd =<<
285 destructHelp (Opt.CtorAccess list Index.second) tl (Opt.Def name root : revDefs)
288destructCtorArg :: Opt.Expr -> [Opt.Def] -> Can.PatternCtorArg -> Names.Tracker [Opt.Def]
289destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =
290 destructHelp (Opt.CtorAccess root index) arg revDefs
294-- TAIL CALL
297optimizePotentialTailCall :: Can.Def -> Names.Tracker Opt.Def
298optimizePotentialTailCall def =
299 case def of
300 Can.Def (A.At _ name) args expr ->
301 do (argNames, defss) <- destructArgs args
302 toTailDef name argNames defss <$>
303 optimizeTailExpr name argNames expr
305 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
306 do (argNames, defss) <- destructArgs (map fst typedArgs)
307 toTailDef name argNames defss <$>
308 optimizeTailExpr name argNames expr
311optimizeTailExpr :: N.Name -> [N.Name] -> Can.Expr -> Names.Tracker Opt.Expr
312optimizeTailExpr name argNames locExpr@(A.At _ expression) =
313 case expression of
314 Can.Call (A.At _ (Can.VarTopLevel _ funcName)) args ->
315 if funcName == name && length args == length argNames then
316 Opt.TailCall name argNames <$> traverse optimizeExpr args
317 else
318 optimizeExpr locExpr
320 Can.If branches finally ->
321 let
322 optimizeBranch (condition, branch) =
323 (,)
324 <$> optimizeExpr condition
325 <*> optimizeTailExpr name argNames branch
326 in
327 Opt.If
328 <$> traverse optimizeBranch branches
329 <*> optimizeTailExpr name argNames finally
331 Can.Let def body ->
332 optimizeDef def =<< optimizeTailExpr name argNames body
334 Can.LetRec defs body ->
335 case defs of
336 [def] ->
337 Opt.Let
338 <$> optimizePotentialTailCall def
339 <*> optimizeTailExpr name argNames body
341 _ ->
342 do obody <- optimizeTailExpr name argNames body
343 foldM (\bod def -> optimizeDef def bod) obody defs
345 Can.LetDestruct pattern expr body ->
346 do (dname, defs) <- destruct pattern
347 oexpr <- optimizeExpr expr
348 obody <- optimizeTailExpr dname argNames body
349 pure $
350 Opt.Let (Opt.Def dname oexpr) (foldr Opt.Let obody defs)
352 Can.Case expr branches ->
353 let
354 optimizeBranch root (Can.CaseBranch pattern branch) =
355 do defs <- destructHelp (Opt.VarLocal root) pattern []
356 obranch <- optimizeTailExpr name argNames branch
357 pure (pattern, foldr Opt.Let obranch defs)
358 in
359 do oexpr <- optimizeExpr expr
360 case oexpr of
361 Opt.VarLocal root ->
362 Case.optimize root <$> traverse (optimizeBranch root) branches
364 _ ->
365 do root <- Names.generate
366 Case.optimize root <$> traverse (optimizeBranch root) branches
368 _ ->
369 optimizeExpr locExpr
373-- DETECT TAIL CALLS
376toTailDef :: N.Name -> [N.Name] -> [[Opt.Def]] -> Opt.Expr -> Opt.Def
377toTailDef name argNames defss body =
378 if hasTailCall body then
379 Opt.TailDef name argNames (foldr Opt.Let body (concat defss))
380 else
381 Opt.Def name (Opt.Function argNames (foldr Opt.Let body (concat defss)))
384hasTailCall :: Opt.Expr -> Bool
385hasTailCall expression =
386 case expression of
387 Opt.TailCall _ _ _ ->
388 True
390 Opt.If branches finally ->
391 hasTailCall finally || any (hasTailCall . snd) branches
393 Opt.Let _ body ->
394 hasTailCall body
396 Opt.Case _ _ branches ->
397 any (hasTailCall . snd) branches
399 _ ->
400 False