@@ -1,25 +1,23 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Optimize (optimize) where
4−
5−import Control.Arrow (second)
6−import qualified Control.Monad as M
7−import Data.Monoid ((<>))
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
14−import qualified AST.Expression.Optimized as Opt
3+module Optimize
4+ ( optimizeExpr
5+ )
6+ where
7+
8+
9+import Control.Monad (foldM)
10+
11+import qualified AST.Canonical as Can
12+import qualified AST.Optimized as Opt
1513import qualified AST.Module.Name as ModuleName
16−import qualified AST.Pattern as P
17−import qualified AST.Variable as Var
18−import qualified Optimize.Case as Case
14+import qualified Data.Index as Index
15+import qualified Elm.Name as N
16+--import qualified Optimize.Case as Case
1917import qualified Optimize.DecisionTree as DT
20−import qualified Optimize.Environment as Env
21−import qualified Optimize.Inline as Inline
22−import qualified Optimize.Port as Port
18+import qualified Optimize.Names as Names
19+--import qualified Optimize.Inline as Inline
20+--import qualified Optimize.Port as Port
2321import qualified Reporting.Annotation as A
2422import qualified Reporting.Region as R
2523
@@ -28,543 +26,353 @@ import qualified Reporting.Region as R
2826-- OPTIMIZE
2927
3028
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
10429
105− (args, body) <- optimizeFunction (Just name) rawArgs rawBody
30+-- EXPRESSIONS
10631
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
15232
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)
15338
154−patternToSubstitutions :: Opt.Expr -> P.Canonical -> [(Text, Opt.Expr)]
155−patternToSubstitutions expr (A.A _ pattern) =
156− case pattern of
157− P.Var name ->
158− [ (name, expr) ]
39+ Can.VarTopLevel home name ->
40+ Names.registerGlobal home name
15941
160− P.Literal _ ->
161− []
42+ Can.VarKernel home name ->
43+ Names.registerKernel home (Opt.VarKernel home name)
16244
163− P.Record fields ->
164− map (\name -> (name, Opt.Access expr name)) fields
45+ Can.VarForeign home name _ ->
46+ Names.registerGlobal home name
16547
166− P.Anything ->
167− []
48+ Can.VarDebug home name _ ->
49+ Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)
16850
169− P.Alias alias realPattern ->
170− (alias, expr) : patternToSubstitutions expr realPattern
51+ Can.VarOperator _ home name _ ->
52+ Names.registerGlobal home name
17153
172− P.Ctor _ patterns ->
173− concat (zipWith (patternToSubstitutions . Opt.CtorAccess expr) [0..] patterns)
54+ Can.Chr chr ->
55+ pure (Opt.Chr chr)
17456
57+ Can.Str str ->
58+ pure (Opt.Str str)
17559
60+ Can.Int int ->
61+ pure (Opt.Int int)
17662
177−-- OPTIMIZE EXPRESSIONS
63+ Can.Float float ->
64+ pure (Opt.Float float)
17865
66+ Can.List entries ->
67+ Opt.List <$> traverse optimizeExpr entries
17968
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]
18173
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])
18279
183−{-| This optimizer detects tail calls. The `Context` holds a function name,
184−function arity, and list of argument names. If a tail call is possible, the
185−`Context` will be filled in and we check any function we run into. If we go
186−down a route that cannot possibly have tail calls, we remove the context.
187−-}
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
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))
19585
196− justConvert =
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
210− <$> traverse justConvert elements
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
237− Env.setTailCall hasTailCall
238− return (Opt.Call optFunc optArgs)
86+ Can.Call func args ->
87+ Opt.Call
88+ <$> optimizeExpr func
89+ <*> traverse optimizeExpr args
23990
24091 Can.If branches finally ->
241− let
242− crawlBranch (cond,branch) =
243− (,) <$> justConvert cond <*> keepLooking branch
244− in
245− Opt.If
246− <$> traverse crawlBranch branches
247− <*> keepLooking finally
248−
249− Can.Let defs body ->
250− do optDefs <- concat <$> traverse optimizeLetDef defs
251− Opt.Let optDefs <$> keepLooking body
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
101+
102+ Can.Let def body ->
103+ optimizeDef def =<< optimizeExpr body
104+
105+ Can.LetRec defs body ->
106+ case defs of
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)
252122
253123 Can.Case expr branches ->
254− do optExpr <- optimizeExpr Nothing expr
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
124+ error "TODO"
261125
262− Can.Ctor (Var.Canonical _ name) exprs ->
263− Opt.Ctor name <$> traverse justConvert exprs
126+ Can.Accessor field ->
127+ pure (Opt.Accessor field)
264128
265129 Can.Access record field ->
266− Opt.Access
267− <$> justConvert record
268− <*> pure field
130+ do optRecord <- optimizeExpr record
131+ pure (Opt.Access optRecord field)
269132
270− Can.Update record fields ->
271− Opt.Update
272− <$> justConvert record
273− <*> traverse (traverse justConvert) fields
133+ Can.Update record updates ->
134+ Opt.Update
135+ <$> optimizeExpr record
136+ <*> traverse optimizeExpr updates
274137
275138 Can.Record fields ->
276− Opt.Record
277− <$> traverse (traverse justConvert) fields
139+ Opt.Record <$> traverse optimizeExpr fields
278140
279− Can.Cmd home manager ->
280− Opt.Cmd home <$> Env.registerEffects home manager
141+ Can.Unit ->
142+ Names.registerKernel N.utils Opt.Unit
281143
282− Can.Sub home manager ->
283− Opt.Sub home <$> Env.registerEffects home manager
144+ Can.Tuple a b maybeC ->
145+ Names.registerKernel N.utils Opt.Tuple
146+ <*> optimizeExpr a
147+ <*> optimizeExpr b
148+ <*> traverse optimizeExpr maybeC
284149
285− Can.OutgoingPort name tipe ->
286− Opt.OutgoingPort name <$> Port.toEncoder tipe
150+ Can.Shader _ src _ ->
151+ pure (Opt.Shader src)
287152
288− Can.IncomingPort name tipe ->
289− Opt.IncomingPort name <$> Port.toDecoder tipe
290153
291− Can.Program main expr ->
292− Opt.Program <$> optimizeMain main <*> justConvert expr
293154
294− Can.SaveEnv _ _ ->
295− error "save_the_environment should never make it to optimization phase"
155+-- DEFINITION
296156
297− Can.GLShader _ src _ ->
298− pure (Opt.GLShader src)
299157
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
300163
164+ Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
165+ optimizeDefHelp name (map fst typedArgs) expr body
301166
302−-- OPTIMIZE VARIABLE
303167
304−
305−optimizeVariable :: R.Region -> Var.Canonical -> Env.Optimizer Opt.Expr
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
337− Can.Static ->
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
356− (pattern, branch) <- tagCrashBranch region rawPattern optBranch
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− )
168+optimizeDefHelp :: N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr
169+optimizeDefHelp name args expr body =
170+ case args of
171+ [] ->
172+ do oexpr <- optimizeExpr expr
173+ pure $ Opt.Let (Opt.Def name oexpr) body
377174
378175 _ ->
379− return (pattern, expr)
380−
381−
382−
383−-- DETECT TAIL CALL
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
384180
385181
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) ) ->
390182
391− if name == ctxName && arity == ctxArity && Var.isLocalHome home then
392− Just (name, argNames)
183+-- DESTRUCTURING
393184
394− else
395− Nothing
396185
397− _ ->
398− Nothing
186+destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [[Opt.Def]])
187+destructArgs args =
188+ unzip <$> traverse destruct args
399189
400190
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, [])
401196
402−-- DEPATTERN
403−-- given a pattern and an expression, push the actual pattern matching into the
404−-- expression as a case-expression if necessary. The pattern compiler will work
405−-- it out from there
197+ Can.PAlias subPattern name ->
198+ do revDefs <- destructHelp (Opt.VarLocal name) subPattern []
199+ pure (name, reverse revDefs)
406200
201+ _ ->
202+ do name <- Names.generate
203+ revDefs <- destructHelp (Opt.VarLocal name) pattern []
204+ pure (name, reverse revDefs)
407205
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))
419206
420− caseify =
421− do name <- Env.freshName
422− return
423− ( name
424− , caseExpr (var name) [ (canPattern, expr) ]
425− )
426− in
207+destructHelp :: Opt.Expr -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
208+destructHelp root (A.At region pattern) revDefs =
427209 case pattern of
428− P.Var name ->
429− return (name, expr)
210+ Can.PAnything ->
211+ pure revDefs
430212
431− P.Literal _ ->
432− caseify
213+ Can.PVar name ->
214+ pure (Opt.Def name root : revDefs)
433215
434− P.Record _ ->
435− caseify
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)
436222
437− P.Anything ->
438− do name <- Env.freshName
439− return (name, expr)
223+ Can.PAlias subPattern name ->
224+ destructHelp (Opt.VarLocal name) subPattern $
225+ Opt.Def name root : revDefs
440226
441− P.Alias _ _ ->
442− caseify
227+ Can.PUnit ->
228+ pure revDefs
443229
444− P.Ctor _ _ ->
445− caseify
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
446238
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
447243
244+ Can.PList [] ->
245+ pure revDefs
448246
449−-- OPTIMIZE BINOPS
247+ Can.PList (hd:tl) ->
248+ destructCons root hd (A.At region (Can.PList tl)) revDefs
450249
250+ Can.PCons hd tl ->
251+ destructCons root hd tl revDefs
451252
452−optimizeBinop
453− :: Context
454− -> R.Region
455− -> Var.Canonical
456− -> Can.Expr
457− -> Can.Expr
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
253+ Can.PChr _ ->
254+ pure revDefs
465255
466− optimizeExpr context (collect id left forwardApply binop)
256+ Can.PStr _ ->
257+ pure revDefs
467258
468− else if op == backwardApply then
259+ Can.PInt _ ->
260+ pure revDefs
469261
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
471268
472− else if op == forwardCompose then
473269
474− do var <- Env.freshName
475− let makeRoot func = ann (Can.App func (ann (Can.Var (Var.local var))))
476− let body = collect makeRoot left forwardCompose binop
477− optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))
270+destructCons :: Opt.Expr -> Can.Pattern -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
271+destructCons 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)
478276
479− else if op == backwardCompose then
480277
481− do var <- Env.freshName
482− let makeRoot func = ann (Can.App func (ann (Can.Var (Var.local var))))
483− let body = collect makeRoot right backwardCompose binop
484− optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))
278+destructCtorArg :: Opt.Expr -> [Opt.Def] -> Can.PatternCtorArg -> Names.Tracker [Opt.Def]
279+destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =
280+ destructHelp (Opt.CtorAccess root index) arg revDefs
485281
486− else if op == cons then
487282
488− optimizeExpr context (ann (Can.Ctor cons [ leftExpr, rightExpr ]))
489−
490− else
491283
492− do optLeft <- optimizeExpr Nothing leftExpr
493− optRight <- optimizeExpr Nothing rightExpr
494− makeOptBinop op optLeft optRight
284+-- TAIL CALL
495285
496286
497−-- left-associative ((x |> f) |> g)
498−forwardApply :: Var.Canonical
499−forwardApply =
500− Var.inCore "Basics" "|>"
287+optimizePotentialTailCall :: Can.Def -> Names.Tracker Opt.Def
288+optimizePotentialTailCall 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
501294
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
502299
503−-- right-associative (g <| (f <| x))
504−backwardApply :: Var.Canonical
505−backwardApply =
506− Var.inCore "Basics" "<|"
507300
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
508309
509−-- left-associative ((f >> g) >> h)
510−forwardCompose :: Var.Canonical
511−forwardCompose =
512− Var.inCore "Basics" ">>"
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
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)
513341
342+ Can.Case expr branches ->
343+ error "TODO"
514344
515−-- right-associative (h << (g << f))
516−backwardCompose :: Var.Canonical
517−backwardCompose =
518− Var.inCore "Basics" "<<"
345+ _ ->
346+ optimizeExpr locExpr
519347
520348
521−cons :: Var.Canonical
522−cons =
523− Var.Canonical Var.BuiltIn "::"
524349
350+-- DETECT TAIL CALLS
525351
526−type Assoc =
527− Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)
528352
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)))
529359
530−left :: Assoc
531−left =
532− flip (,)
533360
361+hasTailCall :: Opt.Expr -> Bool
362+hasTailCall expression =
363+ case expression of
364+ Opt.TailCall _ _ _ ->
365+ True
534366
535−right :: Assoc
536−right =
537− (,)
367+ Opt.If branches finally ->
368+ hasTailCall finally || any (hasTailCall . snd) branches
538369
370+ Opt.Let _ body ->
371+ hasTailCall body
539372
540−collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr
541−collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =
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))
373+ Opt.Case _ _ branches ->
374+ any (hasTailCall . snd) branches
548375
549376 _ ->
550− makeRoot annExpr
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
377+ False
566378
567− Var.TopLevel name ->
568− do let var = Var.Global name op
569− Env.register var
570− return $ Opt.Binop var leftExpr rightExpr