git.iko.soy/elk
on 2da8c0d help sign in
elk/src/Optimize.hs
378 lines 10.0 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
16--import qualified Optimize.Case as Case
17import qualified Optimize.DecisionTree as DT
18import qualified Optimize.Names as Names
19--import qualified Optimize.Inline as Inline
20--import qualified Optimize.Port as Port
21import qualified Reporting.Annotation as A
22import qualified Reporting.Region as R
26-- OPTIMIZE
30-- EXPRESSIONS
33optimizeExpr :: Can.Expr -> Names.Tracker Opt.Expr
34optimizeExpr (A.At region expression) =
35 case expression of
36 Can.VarLocal name ->
37 pure (Opt.VarLocal name)
39 Can.VarTopLevel home name ->
40 Names.registerGlobal home name
42 Can.VarKernel home name ->
43 Names.registerKernel home (Opt.VarKernel home name)
45 Can.VarForeign home name _ ->
46 Names.registerGlobal home name
48 Can.VarDebug home name _ ->
49 Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)
51 Can.VarOperator _ home name _ ->
52 Names.registerGlobal home name
54 Can.Chr chr ->
55 pure (Opt.Chr chr)
57 Can.Str str ->
58 pure (Opt.Str str)
60 Can.Int int ->
61 pure (Opt.Int int)
63 Can.Float float ->
64 pure (Opt.Float float)
66 Can.List entries ->
67 Opt.List <$> traverse optimizeExpr entries
69 Can.Negate expr ->
70 do func <- Names.registerGlobal ModuleName.basics N.negate
71 arg <- optimizeExpr expr
72 pure $ Opt.Call func [arg]
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])
80 Can.Lambda args body ->
81 do (argNames, defss) <- destructArgs args
82 obody <- optimizeExpr body
83 pure $
84 Opt.Function argNames (foldr Opt.Let obody (concat defss))
86 Can.Call func args ->
87 Opt.Call
88 <$> optimizeExpr func
89 <*> traverse optimizeExpr args
91 Can.If branches finally ->
92 let
93 optimizeBranch (condition, branch) =
94 (,)
95 <$> optimizeExpr condition
96 <*> optimizeExpr branch
97 in
98 Opt.If
99 <$> traverse optimizeBranch branches
100 <*> optimizeExpr finally
102 Can.Let def body ->
103 optimizeDef def =<< optimizeExpr body
105 Can.LetRec defs body ->
106 case defs of
107 [def] ->
108 Opt.Let
109 <$> optimizePotentialTailCall def
110 <*> optimizeExpr body
112 _ ->
113 do obody <- optimizeExpr body
114 foldM (\bod def -> optimizeDef def bod) obody defs
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)
123 Can.Case expr branches ->
124 error "TODO"
126 Can.Accessor field ->
127 pure (Opt.Accessor field)
129 Can.Access record field ->
130 do optRecord <- optimizeExpr record
131 pure (Opt.Access optRecord field)
133 Can.Update record updates ->
134 Opt.Update
135 <$> optimizeExpr record
136 <*> traverse optimizeExpr updates
138 Can.Record fields ->
139 Opt.Record <$> traverse optimizeExpr fields
141 Can.Unit ->
142 Names.registerKernel N.utils Opt.Unit
144 Can.Tuple a b maybeC ->
145 Names.registerKernel N.utils Opt.Tuple
146 <*> optimizeExpr a
147 <*> optimizeExpr b
148 <*> traverse optimizeExpr maybeC
150 Can.Shader _ src _ ->
151 pure (Opt.Shader src)
155-- DEFINITION
158optimizeDef :: Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr
159optimizeDef def body =
160 case def of
161 Can.Def (A.At _ name) args expr ->
162 optimizeDefHelp name args expr body
164 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
165 optimizeDefHelp name (map fst typedArgs) expr body
168optimizeDefHelp :: N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr
169optimizeDefHelp name args expr body =
170 case args of
171 [] ->
172 do oexpr <- optimizeExpr expr
173 pure $ Opt.Let (Opt.Def name oexpr) body
175 _ ->
176 do (argNames, defss) <- destructArgs args
177 let func = Opt.Function argNames (foldr Opt.Let body (concat defss))
178 pure $
179 Opt.Let (Opt.Def name func) body
183-- DESTRUCTURING
186destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [[Opt.Def]])
187destructArgs args =
188 unzip <$> traverse destruct args
191destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Def])
192destruct pattern@(A.At _ ptrn) =
193 case ptrn of
194 Can.PVar name ->
195 pure (name, [])
197 Can.PAlias subPattern name ->
198 do revDefs <- destructHelp (Opt.VarLocal name) subPattern []
199 pure (name, reverse revDefs)
201 _ ->
202 do name <- Names.generate
203 revDefs <- destructHelp (Opt.VarLocal name) pattern []
204 pure (name, reverse revDefs)
207destructHelp :: Opt.Expr -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
208destructHelp root (A.At region pattern) revDefs =
209 case pattern of
210 Can.PAnything ->
211 pure revDefs
213 Can.PVar name ->
214 pure (Opt.Def name root : revDefs)
216 Can.PRecord fields ->
217 let
218 toDef field =
219 Opt.Def field (Opt.Access root field)
220 in
221 pure (map toDef fields ++ revDefs)
223 Can.PAlias subPattern name ->
224 destructHelp (Opt.VarLocal name) subPattern $
225 Opt.Def name root : revDefs
227 Can.PUnit ->
228 pure revDefs
230 Can.PTuple a b maybeC ->
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
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
244 Can.PList [] ->
245 pure revDefs
247 Can.PList (hd:tl) ->
248 destructCons root hd (A.At region (Can.PList tl)) revDefs
250 Can.PCons hd tl ->
251 destructCons root hd tl revDefs
253 Can.PChr _ ->
254 pure revDefs
256 Can.PStr _ ->
257 pure revDefs
259 Can.PInt _ ->
260 pure revDefs
262 Can.PCtor _ _ _ _ _ args ->
263 do name <- Names.generate
264 foldM
265 (destructCtorArg (Opt.VarLocal name))
266 (Opt.Def name root : revDefs)
267 args
270destructCons :: Opt.Expr -> Can.Pattern -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
271destructCons root hd tl revDefs =
272 do name <- Names.generate
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)
278destructCtorArg :: Opt.Expr -> [Opt.Def] -> Can.PatternCtorArg -> Names.Tracker [Opt.Def]
279destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =
280 destructHelp (Opt.CtorAccess root index) arg revDefs
284-- TAIL CALL
287optimizePotentialTailCall :: Can.Def -> Names.Tracker Opt.Def
288optimizePotentialTailCall def =
289 case def of
290 Can.Def (A.At _ name) args expr ->
291 do (argNames, defss) <- destructArgs args
292 toTailDef name argNames defss <$>
293 optimizeTailExpr name argNames expr
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
301optimizeTailExpr :: N.Name -> [N.Name] -> Can.Expr -> Names.Tracker Opt.Expr
302optimizeTailExpr 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
310 Can.If branches finally ->
311 let
312 optimizeBranch (condition, branch) =
313 (,)
314 <$> optimizeExpr condition
315 <*> optimizeTailExpr name argNames branch
316 in
317 Opt.If
318 <$> traverse optimizeBranch branches
319 <*> optimizeTailExpr name argNames finally
321 Can.Let def body ->
322 optimizeDef def =<< optimizeTailExpr name argNames body
324 Can.LetRec defs body ->
325 case defs of
326 [def] ->
327 Opt.Let
328 <$> optimizePotentialTailCall def
329 <*> optimizeTailExpr name argNames body
331 _ ->
332 do obody <- optimizeTailExpr name argNames body
333 foldM (\bod def -> optimizeDef def bod) obody defs
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)
342 Can.Case expr branches ->
343 error "TODO"
345 _ ->
346 optimizeExpr locExpr
350-- DETECT TAIL CALLS
353toTailDef :: N.Name -> [N.Name] -> [[Opt.Def]] -> Opt.Expr -> Opt.Def
354toTailDef 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)))
361hasTailCall :: Opt.Expr -> Bool
362hasTailCall expression =
363 case expression of
364 Opt.TailCall _ _ _ ->
365 True
367 Opt.If branches finally ->
368 hasTailCall finally || any (hasTailCall . snd) branches
370 Opt.Let _ body ->
371 hasTailCall body
373 Opt.Case _ _ branches ->
374 any (hasTailCall . snd) branches
376 _ ->
377 False