@@ -1,12 +1,8 @@
11module Optimize (optimize) where
22
33import Control.Applicative
4−import Control.Arrow (second)
54import qualified Control.Monad as M
65import qualified Control.Monad.State as State
7−import qualified Data.Map as Map
8−import Data.Map ((!))
9−import qualified Data.Maybe as Maybe
106import qualified Data.Traversable as T
117
128import qualified AST.Expression.General as Expr
@@ -16,8 +12,8 @@ import qualified AST.Module as Module
1612import qualified AST.Module.Name as ModuleName
1713import qualified AST.Pattern as P
1814import qualified AST.Variable as Var
19−import Elm.Utils ((|>))
20−import qualified Optimize.Cases as Cases
15+import qualified Optimize.Environment as Env
16+import qualified Optimize.Patterns as Patterns
2117import qualified Reporting.Annotation as A
2218import qualified Reporting.Region as R
2319
@@ -35,7 +31,7 @@ optimize module_ =
3531 in
3632 State.evalState
3733 (concat <$> mapM (optimizeDef (Just home)) defs)
38− (Env False 0)
34+ (Env.Env False 0)
3935
4036
4137flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)
@@ -48,32 +44,9 @@ flattenLets defs annExpr@(A.A _ expr) =
4844 (defs, annExpr)
4945
5046
51−-- TRACKER TO THREAD FINDINGS THROUGH TRAVERSAL
52−
53−type Optimizer a =
54− State.State Env a
55−
56−
57−data Env = Env
58− { _hasTailCall :: Bool
59− , _uid :: Int
60− }
61−
62−
63−setTailCall :: Bool -> Optimizer ()
64−setTailCall bool =
65− do uid <- State.gets _uid
66− State.put (Env bool uid)
67−
68−
69−mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)
70−mapSnd func (x, a) =
71− (,) x <$> func a
72−
73−
7447-- CONVERT DEFINITIONS
7548
76−optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Optimizer [Opt.Def]
49+optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Env.Optimizer [Opt.Def]
7750optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =
7851 let
7952 (args, rawBody) =
@@ -82,13 +55,13 @@ optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expressio
8255 case (ptrn, args) of
8356 (P.Var name, _ : _) ->
8457
85− do (Env htc uid) <- State.get
86− State.put (Env False uid)
58+ do (Env.Env htc uid) <- State.get
59+ State.put (Env.Env False uid)
8760
8861 (args, body) <- optimizeFunction (Just name) args rawBody
8962
90− (Env isTailCall uid') <- State.get
91− State.put (Env htc uid')
63+ (Env.Env isTailCall uid') <- State.get
64+ State.put (Env.Env htc uid')
9265
9366 let facts = Opt.Facts home deps
9467
@@ -103,14 +76,14 @@ optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expressio
10376
10477 (P.Var name, []) ->
10578
106− do hasTailCall <- State.gets _hasTailCall
79+ do hasTailCall <- State.gets Env._hasTailCall
10780 body <- optimizeExpr Nothing rawBody
108− setTailCall hasTailCall
81+ Env.setTailCall hasTailCall
10982 return [ Opt.Def (Opt.Facts home deps) name body ]
11083
11184 (_, []) ->
11285
113− do name <- freshName
86+ do name <- Env.freshName
11487 optBody <- optimizeExpr Nothing rawBody
11588 let optDef = Opt.Def (Opt.Facts home deps) name optBody
11689 return (optDef : patternToDefs home name pattern)
@@ -125,7 +98,7 @@ optimizeFunction
12598 :: Maybe String
12699 -> [P.CanonicalPattern]
127100 -> Can.Expr
128− -> Optimizer ([String], Opt.Expr)
101+ -> Env.Optimizer ([String], Opt.Expr)
129102optimizeFunction maybeName patterns givenBody =
130103 do (argNames, body) <- M.foldM depatternArgs ([], givenBody) (reverse patterns)
131104 optBody <- optimizeExpr (makeContext argNames =<< maybeName) body
@@ -140,7 +113,7 @@ makeContext argNames name =
140113depatternArgs
141114 :: ([String], Can.Expr)
142115 -> P.CanonicalPattern
143− -> Optimizer ([String], Can.Expr)
116+ -> Env.Optimizer ([String], Can.Expr)
144117depatternArgs (names, rawExpr) ptrn =
145118 do (name, expr) <- depattern ptrn rawExpr
146119 return (name : names, expr)
@@ -203,7 +176,7 @@ function arity, and list of argument names. If a tail call is possible, the
203176`Context` will be filled in and we check any function we run into. If we go
204177down a route that cannot possibly have tail calls, we remove the context.
205178-}
206−optimizeExpr :: Context -> Can.Expr -> Optimizer Opt.Expr
179+optimizeExpr :: Context -> Can.Expr -> Env.Optimizer Opt.Expr
207180optimizeExpr context annExpr@(A.A region expression) =
208181 let
209182 keepLooking =
@@ -250,17 +223,16 @@ optimizeExpr context annExpr@(A.A region expression) =
250223 case isTailCall context func (length args) of
251224 Just (name, argNames) ->
252225 do optArgs <- T.traverse justConvert args
253− setTailCall True
226+ Env.setTailCall True
254227 return (Opt.TailCall name argNames optArgs)
255228
256229 Nothing ->
257− do hasTailCall <- State.gets _hasTailCall
230+ do hasTailCall <- State.gets Env._hasTailCall
258231 optFunc <- justConvert func
259232 optArgs <- T.traverse justConvert args
260− setTailCall hasTailCall
233+ Env.setTailCall hasTailCall
261234 return (Opt.Call optFunc optArgs)
262235
263−
264236 Expr.If branches finally ->
265237 let
266238 crawlBranch (cond,branch) =
@@ -275,7 +247,9 @@ optimizeExpr context annExpr@(A.A region expression) =
275247 Opt.Let optDefs <$> keepLooking body
276248
277249 Expr.Case expr branches ->
278− optimizeCase context region expr branches
250+ do optExpr <- optimizeExpr Nothing expr
251+ optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches
252+ Patterns.optimize region optExpr optBranches
279253
280254 Expr.Data name exprs ->
281255 Opt.Data name <$> T.traverse justConvert exprs
@@ -310,6 +284,11 @@ optimizeExpr context annExpr@(A.A region expression) =
310284 (\e -> Expr.Task name e tipe) <$> justConvert expr
311285
312286
287+mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)
288+mapSnd func (x, a) =
289+ (,) x <$> func a
290+
291+
313292-- DETECT TAIL CALL
314293
315294isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
@@ -327,13 +306,12 @@ isTailCall context (A.A _ function) arity =
327306 Nothing
328307
329308
330−
331309-- DEPATTERN
332310-- given a pattern and an expression, push the actual pattern matching into the
333311-- expression as a case-expression if necessary. The pattern compiler will work
334312-- it out from there
335313
336−depattern :: P.CanonicalPattern -> Can.Expr -> Optimizer (String, Can.Expr)
314+depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)
337315depattern canPattern@(A.A _ pattern) expr =
338316 let
339317 ann =
@@ -346,7 +324,7 @@ depattern canPattern@(A.A _ pattern) expr =
346324 ann (Expr.Var (Var.local name))
347325
348326 caseify =
349− do name <- freshName
327+ do name <- Env.freshName
350328 return
351329 ( name
352330 , caseExpr (var name) [ (canPattern, expr) ]
@@ -363,7 +341,7 @@ depattern canPattern@(A.A _ pattern) expr =
363341 caseify
364342
365343 P.Anything ->
366− do name <- freshName
344+ do name <- Env.freshName
367345 return (name, expr)
368346
369347 P.Alias _ _ ->
@@ -373,122 +351,6 @@ depattern canPattern@(A.A _ pattern) expr =
373351 caseify
374352
375353
376−freshName :: Optimizer String
377−freshName =
378− do (Env htc uid) <- State.get
379− State.put (Env htc (uid + 1))
380− return ("_p" ++ show uid)
381−
382−
383−-- OPTIMIZE CASES
384−
385−optimizeCase
386− :: Context
387− -> R.Region
388− -> Can.Expr
389− -> [(P.CanonicalPattern, Can.Expr)]
390− -> Optimizer Opt.Expr
391−optimizeCase context region expr rawBranches =
392− let
393− indexify index (pattern, branch) =
394− ( (pattern, index)
395− , (index, branch)
396− )
397− in
398− do optBranches <- T.traverse (mapSnd (optimizeExpr context)) rawBranches
399− crashBranches <-
400− case last optBranches of
401− (A.A ann P.Anything, Opt.Call (Opt.Crash _ _) [arg]) ->
402− do name <- freshName
403− let newPattern = A.A ann (P.Var name)
404− let newCall = Opt.Call (Opt.Crash region (Just name)) [arg]
405− return (init optBranches ++ [(newPattern, newCall)])
406−
407− _ ->
408− return optBranches
409−
410− let (patterns, indexedBranches) =
411− unzip (zipWith indexify [0..] crashBranches)
412−
413− let decisionTree =
414− Cases.compile (error "need a VariantDict") patterns
415−
416− optExpr <- optimizeExpr Nothing expr
417−
418− return (inlinedCase optExpr decisionTree indexedBranches)
419−
420−
421−inlinedCase
422− :: Opt.Expr
423− -> Cases.DecisionTree Cases.Jump
424− -> [(Int, Opt.Expr)]
425− -> Opt.Expr
426−inlinedCase expr decisionTree jumpTargets =
427− let
428− substitutionDict =
429− gatherSubstitutions decisionTree
430−
431− (jumps, sharedBranches) =
432− unzip (map (toJumps substitutionDict) jumpTargets)
433− in
434− Opt.Case
435− expr
436− (inlineJumps (Map.fromList jumps) decisionTree)
437− (Maybe.catMaybes sharedBranches)
438−
439−
440−gatherSubstitutions
441− :: Cases.DecisionTree Cases.Jump
442− -> Map.Map Int [[(String, Cases.Path)]]
443−gatherSubstitutions decisionTree =
444− case decisionTree of
445− Cases.Decision _ edges fallback ->
446− map snd edges
447− |> maybe id (:) fallback
448− |> map gatherSubstitutions
449− |> Map.unionsWith (++)
450−
451− Cases.Match (Cases.Jump target substitutions) ->
452− Map.singleton target [substitutions]
453−
454−
455−toJumps
456− :: Map.Map Int [[(String, Cases.Path)]]
457− -> (Int, Opt.Expr)
458− -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )
459−toJumps substitutionDict (target, branch) =
460− case substitutionDict ! target of
461− [substitutions] ->
462− ( (target, Opt.Inline (Opt.Branch substitutions branch))
463− , Nothing
464− )
465−
466− substitutions : _ ->
467− ( (target, Opt.Jump target)
468− , Just (target, Opt.Branch substitutions branch)
469− )
470−
471− _ ->
472− error "it is not possible for there to be no substitutions"
473−
474−
475−inlineJumps
476− :: Map.Map Int Opt.Jump
477− -> Cases.DecisionTree Cases.Jump
478− -> Cases.DecisionTree Opt.Jump
479−inlineJumps jumpDict decisionTree =
480− let
481− go =
482− inlineJumps jumpDict
483− in
484− case decisionTree of
485− Cases.Decision test edges fallback ->
486− Cases.Decision test (map (second go) edges) (fmap go fallback)
487−
488− Cases.Match (Cases.Jump target _) ->
489− Cases.Match (jumpDict ! target)
490−
491−
492354-- OPTIMIZE BINOPS
493355
494356optimizeBinop
@@ -497,7 +359,7 @@ optimizeBinop
497359 -> Var.Canonical
498360 -> Can.Expr
499361 -> Can.Expr
500− -> Optimizer Opt.Expr
362+ -> Env.Optimizer Opt.Expr
501363optimizeBinop context region op leftExpr rightExpr =
502364 let
503365 ann = A.A region
@@ -513,14 +375,14 @@ optimizeBinop context region op leftExpr rightExpr =
513375
514376 else if op == forwardCompose then
515377
516− do var <- freshName
378+ do var <- Env.freshName
517379 let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))
518380 let body = collect makeRoot left forwardCompose binop
519381 optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))
520382
521383 else if op == backwardCompose then
522384
523− do var <- freshName
385+ do var <- Env.freshName
524386 let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))
525387 let body = collect makeRoot right backwardCompose binop
526388 optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))