git.iko.soy/elk
on 7dbdaae help sign in
elk/compiler/src/Optimize/Expression.hs
479 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Expression
4 ( Cycle
5 , optimize
6 , destructArgs
7 , optimizePotentialTailCall
8 )
9 where
12import Prelude hiding (cycle)
13import Control.Monad (foldM)
14import qualified Data.Set as Set
16import qualified AST.Canonical as Can
17import qualified AST.Optimized as Opt
18import qualified AST.Module.Name as ModuleName
19import qualified Data.Index as Index
20import qualified Elm.Name as N
21import qualified Optimize.Case as Case
22import qualified Optimize.Names as Names
23import qualified Reporting.Annotation as A
27-- OPTIMIZE
30type Cycle =
31 Set.Set N.Name
34optimize :: Cycle -> Can.Expr -> Names.Tracker Opt.Expr
35optimize cycle (A.At region expression) =
36 case expression of
37 Can.VarLocal name ->
38 pure (Opt.VarLocal name)
40 Can.VarTopLevel home name ->
41 if Set.member name cycle then
42 pure (Opt.VarCycle home name)
43 else
44 Names.registerGlobal home name
46 Can.VarKernel home name ->
47 Names.registerKernel home (Opt.VarKernel home name)
49 Can.VarForeign home name _ ->
50 Names.registerGlobal home name
52 Can.VarCtor opts home name index _ ->
53 Names.registerCtor home name index opts
55 Can.VarDebug home name _ ->
56 Names.registerDebug name home region
58 Can.VarOperator _ home name _ ->
59 Names.registerGlobal home name
61 Can.Chr chr ->
62 Names.registerKernel N.utils (Opt.Chr chr)
64 Can.Str str ->
65 pure (Opt.Str str)
67 Can.Int int ->
68 pure (Opt.Int int)
70 Can.Float float ->
71 pure (Opt.Float float)
73 Can.List entries ->
74 Names.registerKernel N.list Opt.List
75 <*> traverse (optimize cycle) entries
77 Can.Negate expr ->
78 do func <- Names.registerGlobal ModuleName.basics N.negate
79 arg <- optimize cycle expr
80 pure $ Opt.Call func [arg]
82 Can.Binop _ home name _ left right ->
83 do optFunc <- Names.registerGlobal home name
84 optLeft <- optimize cycle left
85 optRight <- optimize cycle right
86 return (Opt.Call optFunc [optLeft, optRight])
88 Can.Lambda args body ->
89 do (argNames, destructors) <- destructArgs args
90 obody <- optimize cycle body
91 pure $ Opt.Function argNames (foldr Opt.Destruct obody destructors)
93 Can.Call func args ->
94 Opt.Call
95 <$> optimize cycle func
96 <*> traverse (optimize cycle) args
98 Can.If branches finally ->
99 let
100 optimizeBranch (condition, branch) =
101 (,)
102 <$> optimize cycle condition
103 <*> optimize cycle branch
104 in
105 Opt.If
106 <$> traverse optimizeBranch branches
107 <*> optimize cycle finally
109 Can.Let def body ->
110 optimizeDef cycle def =<< optimize cycle body
112 Can.LetRec defs body ->
113 case defs of
114 [def] ->
115 Opt.Let
116 <$> optimizePotentialTailCall cycle def
117 <*> optimize cycle body
119 _ ->
120 do obody <- optimize cycle body
121 foldM (\bod def -> optimizeDef cycle def bod) obody defs
123 Can.LetDestruct pattern expr body ->
124 do (name, destructs) <- destruct pattern
125 oexpr <- optimize cycle expr
126 obody <- optimize cycle body
127 pure $
128 Opt.Let (Opt.Def name oexpr) (foldr Opt.Destruct obody destructs)
130 Can.Case expr branches ->
131 let
132 optimizeBranch root (Can.CaseBranch pattern branch) =
133 do destructors <- destructCase root pattern
134 obranch <- optimize cycle branch
135 pure (pattern, foldr Opt.Destruct obranch destructors)
136 in
137 do temp <- Names.generate
138 oexpr <- optimize cycle expr
139 case oexpr of
140 Opt.VarLocal root ->
141 Case.optimize temp root <$> traverse (optimizeBranch root) branches
143 _ ->
144 do obranches <- traverse (optimizeBranch temp) branches
145 return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches)
147 Can.Accessor field ->
148 Names.registerField field (Opt.Accessor field)
150 Can.Access record (A.At _ field) ->
151 do optRecord <- optimize cycle record
152 Names.registerField field (Opt.Access optRecord field)
154 Can.Update _ record updates ->
155 Names.registerFieldDict updates Opt.Update
156 <*> optimize cycle record
157 <*> traverse (optimizeUpdate cycle) updates
159 Can.Record fields ->
160 Names.registerFieldDict fields Opt.Record
161 <*> traverse (optimize cycle) fields
163 Can.Unit ->
164 Names.registerKernel N.utils Opt.Unit
166 Can.Tuple a b maybeC ->
167 Names.registerKernel N.utils Opt.Tuple
168 <*> optimize cycle a
169 <*> optimize cycle b
170 <*> traverse (optimize cycle) maybeC
172 Can.Shader _ src _ ->
173 pure (Opt.Shader src)
177-- UPDATE
180optimizeUpdate :: Cycle -> Can.FieldUpdate -> Names.Tracker Opt.Expr
181optimizeUpdate cycle (Can.FieldUpdate _ expr) =
182 optimize cycle expr
186-- DEFINITION
189optimizeDef :: Cycle -> Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr
190optimizeDef cycle def body =
191 case def of
192 Can.Def (A.At _ name) args expr ->
193 optimizeDefHelp cycle name args expr body
195 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
196 optimizeDefHelp cycle name (map fst typedArgs) expr body
199optimizeDefHelp :: Cycle -> N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr
200optimizeDefHelp cycle name args expr body =
201 do oexpr <- optimize cycle expr
202 case args of
203 [] ->
204 pure $ Opt.Let (Opt.Def name oexpr) body
206 _ ->
207 do (argNames, destructors) <- destructArgs args
208 let ofunc = Opt.Function argNames (foldr Opt.Destruct oexpr destructors)
209 pure $ Opt.Let (Opt.Def name ofunc) body
213-- DESTRUCTURING
216destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [Opt.Destructor])
217destructArgs args =
218 do (argNames, destructorLists) <- unzip <$> traverse destruct args
219 return (argNames, concat destructorLists)
222destructCase :: N.Name -> Can.Pattern -> Names.Tracker [Opt.Destructor]
223destructCase rootName pattern =
224 reverse <$> destructHelp (Opt.Root rootName) pattern []
227destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Destructor])
228destruct pattern@(A.At _ ptrn) =
229 case ptrn of
230 Can.PVar name ->
231 pure (name, [])
233 Can.PAlias subPattern name ->
234 do revDs <- destructHelp (Opt.Root name) subPattern []
235 pure (name, reverse revDs)
237 _ ->
238 do name <- Names.generate
239 revDs <- destructHelp (Opt.Root name) pattern []
240 pure (name, reverse revDs)
243destructHelp :: Opt.Path -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]
244destructHelp path (A.At region pattern) revDs =
245 case pattern of
246 Can.PAnything ->
247 pure revDs
249 Can.PVar name ->
250 pure (Opt.Destructor name path : revDs)
252 Can.PRecord fields ->
253 let
254 toDestruct name =
255 Opt.Destructor name (Opt.Field name path)
256 in
257 Names.registerFieldList fields (map toDestruct fields ++ revDs)
259 Can.PAlias subPattern name ->
260 destructHelp (Opt.Root name) subPattern $
261 Opt.Destructor name path : revDs
263 Can.PUnit ->
264 pure revDs
266 Can.PTuple a b Nothing ->
267 destructTwo path a b revDs
269 Can.PTuple a b (Just c) ->
270 case path of
271 Opt.Root _ ->
272 destructHelp (Opt.Index Index.third path) c =<<
273 destructHelp (Opt.Index Index.second path) b =<<
274 destructHelp (Opt.Index Index.first path) a revDs
276 _ ->
277 do name <- Names.generate
278 let newRoot = Opt.Root name
279 destructHelp (Opt.Index Index.third newRoot) c =<<
280 destructHelp (Opt.Index Index.second newRoot) b =<<
281 destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path : revDs)
283 Can.PList [] ->
284 pure revDs
286 Can.PList (hd:tl) ->
287 destructTwo path hd (A.At region (Can.PList tl)) revDs
289 Can.PCons hd tl ->
290 destructTwo path hd tl revDs
292 Can.PChr _ ->
293 pure revDs
295 Can.PStr _ ->
296 pure revDs
298 Can.PInt _ ->
299 pure revDs
301 Can.PBool _ _ ->
302 pure revDs
304 Can.PCtor _ _ (Can.Union _ _ _ opts) _ _ args ->
305 case args of
306 [Can.PatternCtorArg _ _ arg] ->
307 case opts of
308 Can.Normal -> destructHelp (Opt.Index Index.first path) arg revDs
309 Can.Unbox -> destructHelp (Opt.Unbox path) arg revDs
310 Can.Enum -> destructHelp (Opt.Index Index.first path) arg revDs
312 _ ->
313 case path of
314 Opt.Root _ ->
315 foldM (destructCtorArg path) revDs args
317 _ ->
318 do name <- Names.generate
319 foldM (destructCtorArg (Opt.Root name)) (Opt.Destructor name path : revDs) args
322destructTwo :: Opt.Path -> Can.Pattern -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]
323destructTwo path a b revDs =
324 case path of
325 Opt.Root _ ->
326 destructHelp (Opt.Index Index.second path) b =<<
327 destructHelp (Opt.Index Index.first path) a revDs
329 _ ->
330 do name <- Names.generate
331 let newRoot = Opt.Root name
332 destructHelp (Opt.Index Index.second newRoot) b =<<
333 destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path : revDs)
336destructCtorArg :: Opt.Path -> [Opt.Destructor] -> Can.PatternCtorArg -> Names.Tracker [Opt.Destructor]
337destructCtorArg path revDs (Can.PatternCtorArg index _ arg) =
338 destructHelp (Opt.Index index path) arg revDs
342-- TAIL CALL
345optimizePotentialTailCall :: Cycle -> Can.Def -> Names.Tracker Opt.Def
346optimizePotentialTailCall cycle def =
347 case def of
348 Can.Def (A.At _ name) args expr ->
349 do (argNames, destructors) <- destructArgs args
350 toTailDef name argNames destructors <$>
351 optimizeTail cycle name argNames expr
353 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
354 do (argNames, destructors) <- destructArgs (map fst typedArgs)
355 toTailDef name argNames destructors <$>
356 optimizeTail cycle name argNames expr
359optimizeTail :: Cycle -> N.Name -> [N.Name] -> Can.Expr -> Names.Tracker Opt.Expr
360optimizeTail cycle rootName argNames locExpr@(A.At _ expression) =
361 case expression of
362 Can.Call func@(A.At _ (Can.VarTopLevel _ name)) args ->
363 do oargs <- traverse (optimize cycle) args
364 if name == rootName
365 then
366 case Index.indexedZipWith (\_ a b -> (a,b)) argNames oargs of
367 Index.LengthMatch pairs ->
368 pure $ Opt.TailCall name pairs
370 Index.LengthMismatch _ _ ->
371 do ofunc <- optimize cycle func
372 pure $ Opt.Call ofunc oargs
373 else
374 do ofunc <- optimize cycle func
375 pure $ Opt.Call ofunc oargs
377 Can.If branches finally ->
378 let
379 optimizeBranch (condition, branch) =
380 (,)
381 <$> optimize cycle condition
382 <*> optimizeTail cycle rootName argNames branch
383 in
384 Opt.If
385 <$> traverse optimizeBranch branches
386 <*> optimizeTail cycle rootName argNames finally
388 Can.Let def body ->
389 optimizeDef cycle def =<< optimizeTail cycle rootName argNames body
391 Can.LetRec defs body ->
392 case defs of
393 [def] ->
394 Opt.Let
395 <$> optimizePotentialTailCall cycle def
396 <*> optimizeTail cycle rootName argNames body
398 _ ->
399 do obody <- optimizeTail cycle rootName argNames body
400 foldM (\bod def -> optimizeDef cycle def bod) obody defs
402 Can.LetDestruct pattern expr body ->
403 do (dname, destructors) <- destruct pattern
404 oexpr <- optimize cycle expr
405 obody <- optimizeTail cycle dname argNames body
406 pure $
407 Opt.Let (Opt.Def dname oexpr) (foldr Opt.Destruct obody destructors)
409 Can.Case expr branches ->
410 let
411 optimizeBranch root (Can.CaseBranch pattern branch) =
412 do destructors <- destructCase root pattern
413 obranch <- optimizeTail cycle rootName argNames branch
414 pure (pattern, foldr Opt.Destruct obranch destructors)
415 in
416 do temp <- Names.generate
417 oexpr <- optimize cycle expr
418 case oexpr of
419 Opt.VarLocal root ->
420 Case.optimize temp root <$> traverse (optimizeBranch root) branches
422 _ ->
423 do obranches <- traverse (optimizeBranch temp) branches
424 return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches)
426 _ ->
427 optimize cycle locExpr
431-- DETECT TAIL CALLS
434toTailDef :: N.Name -> [N.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def
435toTailDef name argNames destructors body =
436 if hasTailCall body then
437 Opt.TailDef name argNames (foldr Opt.Destruct body destructors)
438 else
439 Opt.Def name (Opt.Function argNames (foldr Opt.Destruct body destructors))
442hasTailCall :: Opt.Expr -> Bool
443hasTailCall expression =
444 case expression of
445 Opt.TailCall _ _ ->
446 True
448 Opt.If branches finally ->
449 hasTailCall finally || any (hasTailCall . snd) branches
451 Opt.Let _ body ->
452 hasTailCall body
454 Opt.Destruct _ body ->
455 hasTailCall body
457 Opt.Case _ _ decider jumps ->
458 decidecHasTailCall decider || any (hasTailCall . snd) jumps
460 _ ->
461 False
464decidecHasTailCall :: Opt.Decider Opt.Choice -> Bool
465decidecHasTailCall decider =
466 case decider of
467 Opt.Leaf choice ->
468 case choice of
469 Opt.Inline expr ->
470 hasTailCall expr
472 Opt.Jump _ ->
473 False
475 Opt.Chain _ success failure ->
476 decidecHasTailCall success || decidecHasTailCall failure
478 Opt.FanOut _ tests fallback ->
479 decidecHasTailCall fallback || any (decidecHasTailCall . snd) tests