git.iko.soy/elk
on master help sign in
Begin generating optimized pattern matches
3f6dcdbEvan Czaplicki
src/AST/Expression/Optimized.hs+7−2
compare with master
unifiedsplit
@@ -1,6 +1,6 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module AST.Expression.Optimized
2module AST.Expression.Optimized
3− ( Def(..), Facts(..)
3+ ( Def(..), Facts(..), dummyFacts
4 , Expr(..), Jump(..), Branch(..)
4 , Expr(..), Jump(..), Branch(..)
5 ) where
5 ) where
6
6
@@ -27,6 +27,11 @@ data Facts = Facts
27 }
27 }
28
28
29
29
30+dummyFacts :: Facts
31+dummyFacts =
32+ Facts Nothing []
33+
34+
30-- EXPRESSIONS
35-- EXPRESSIONS
31
36
32data Expr
37data Expr
@@ -40,7 +45,7 @@ data Expr
40 | TailCall String [String] [Expr]
45 | TailCall String [String] [Expr]
41 | If [(Expr, Expr)] Expr
46 | If [(Expr, Expr)] Expr
42 | Let [Def] Expr
47 | Let [Def] Expr
43− | Case Expr (DT.DecisionTree Jump) [(Int, Branch)]
48+ | Case String (DT.DecisionTree Jump) [(Int, Branch)]
44 | Data String [Expr]
49 | Data String [Expr]
45 | DataAccess Expr Int
50 | DataAccess Expr Int
46 | Access Expr String
51 | Access Expr String
src/Generate/JavaScript.hs+114−9
@@ -11,7 +11,7 @@ import qualified Text.PrettyPrint.Leijen as PP
11
11
12import qualified AST.Expression.General as Expr
12import qualified AST.Expression.General as Expr
13import AST.Expression.Optimized as Opt
13import AST.Expression.Optimized as Opt
14−import AST.Literal
14+import qualified AST.Literal as L
15import qualified AST.Module as Module
15import qualified AST.Module as Module
16import qualified AST.Module.Name as ModuleName
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Variable as Var
17import qualified AST.Variable as Var
@@ -195,8 +195,8 @@ generateCode expr =
195 If branches finally ->
195 If branches finally ->
196 generateIf branches finally
196 generateIf branches finally
197
197
198− Case expr decisionTree branches ->
198+ Case root decisionTree branches ->
199− generateCase expr decisionTree branches
199+ JsBlock <$> generateCase root decisionTree branches
200
200
201 ExplicitList elements ->
201 ExplicitList elements ->
202 do jsElements <- mapM generateJsExpr elements
202 do jsElements <- mapM generateJsExpr elements
@@ -215,7 +215,7 @@ generateCode expr =
215 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
215 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
216
216
217 GLShader _uid src _tipe ->
217 GLShader _uid src _tipe ->
218− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]
218+ jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
219
219
220 Port impl ->
220 Port impl ->
221 case impl of
221 case impl of
@@ -319,7 +319,7 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
319 _ ->
319 _ ->
320 (reverse visitedBranches, finally)
320 (reverse visitedBranches, finally)
321
321
322− (Literal (Boolean True), branch) : _ ->
322+ (Literal (L.Boolean True), branch) : _ ->
323 crushIfsHelp visitedBranches [] branch
323 crushIfsHelp visitedBranches [] branch
324
324
325 visiting : unvisited ->
325 visiting : unvisited ->
@@ -329,12 +329,117 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
329-- CASE EXPRESSIONS
329-- CASE EXPRESSIONS
330
330
331generateCase
331generateCase
332− :: Opt.Expr
332+ :: String
333 -> DT.DecisionTree Opt.Jump
333 -> DT.DecisionTree Opt.Jump
334 -> [(Int, Opt.Branch)]
334 -> [(Int, Opt.Branch)]
335− -> State Int Code
335+ -> State Int [Statement ()]
336−generateCase expr decisionTree branches =
336+generateCase root decisionTree jumpBranches =
337− error "TODO"
337+ do decider <- generateDecisionTree root decisionTree
338+ foldM (goto root) decider jumpBranches
339+
340+
341+goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
342+goto root decider (target, branch) =
343+ let
344+ deciderStmt =
345+ LabelledStmt ()
346+ (targetLabel root target)
347+ (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
348+ in
349+ do stmts <- generateBranch root branch
350+ return (deciderStmt : stmts)
351+
352+
353+targetLabel :: String -> Int -> Id ()
354+targetLabel root target =
355+ Id () (root ++ "_" ++ show target)
356+
357+
358+generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
359+generateDecisionTree root decisionTree =
360+ case decisionTree of
361+ DT.Match (Opt.Inline branch) ->
362+ generateBranch root branch
363+
364+ DT.Match (Opt.Jump target) ->
365+ return [ BreakStmt () (Just (targetLabel root target)) ]
366+
367+ DT.Decision testPath edges fallback ->
368+ do accessExpr <- generateJsExpr (pathToExpr root testPath)
369+
370+ let testExpr =
371+ case fst (head edges) of
372+ DT.Constructor _ ->
373+ DotRef () accessExpr (Id () "ctor")
374+
375+ DT.Literal _ ->
376+ accessExpr
377+
378+ caseClauses <- mapM (edgeToCaseClause root) edges
379+ caseDefault <- fallbackToDefault root fallback
380+
381+ return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
382+
383+
384+edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
385+edgeToCaseClause root (test, subTree) =
386+ CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
387+
388+
389+testToExpr :: DT.Test -> Expression ()
390+testToExpr test =
391+ case test of
392+ DT.Constructor (Var.Canonical _ tag) ->
393+ StringLit () tag
394+
395+ DT.Literal (L.Chr char) ->
396+ StringLit () [char]
397+
398+ DT.Literal lit ->
399+ Literal.literal lit
400+
401+
402+fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
403+fallbackToDefault root fallback =
404+ case fallback of
405+ Nothing ->
406+ return []
407+
408+ Just subTree ->
409+ do stmts <- generateDecisionTree root subTree
410+ return [ CaseDefault () stmts ]
411+
412+
413+generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
414+generateBranch root (Opt.Branch substitutions expr) =
415+ do subts <- mapM (loadPath root) substitutions
416+ code <- generateCode expr
417+ return (subts ++ toStatementList code)
418+
419+
420+loadPath :: String -> (String, DT.Path) -> State Int (Statement ())
421+loadPath root (name, path) =
422+ do jsAccessExpr <- generateJsExpr (pathToExpr root path)
423+ return $ VarDeclStmt () [ varDecl name jsAccessExpr ]
424+
425+
426+pathToExpr :: String -> DT.Path -> Opt.Expr
427+pathToExpr root fullPath =
428+ go (Opt.Var (Var.local root)) fullPath
429+ where
430+ go expr path =
431+ case path of
432+ DT.Position index subpath ->
433+ go (Opt.DataAccess expr index) subpath
434+
435+ DT.Field field subpath ->
436+ go (Opt.Access expr field) subpath
437+
438+ DT.Empty ->
439+ expr
440+
441+ DT.Alias ->
442+ expr
338
443
339
444
340-- BINARY OPERATORS
445-- BINARY OPERATORS
src/Optimize.hs+26−16
@@ -2,7 +2,7 @@ module Optimize (optimize) where
2
2
3import Control.Applicative
3import Control.Applicative
4import qualified Control.Monad as M
4import qualified Control.Monad as M
5−import qualified Control.Monad.State as State
5+import qualified Data.Map as Map
6import qualified Data.Traversable as T
6import qualified Data.Traversable as T
7
7
8import qualified AST.Expression.General as Expr
8import qualified AST.Expression.General as Expr
@@ -12,6 +12,7 @@ import qualified AST.Module as Module
12import qualified AST.Module.Name as ModuleName
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Pattern as P
13import qualified AST.Pattern as P
14import qualified AST.Variable as Var
14import qualified AST.Variable as Var
15+import Elm.Utils ((|>))
15import qualified Optimize.Environment as Env
16import qualified Optimize.Environment as Env
16import qualified Optimize.Patterns as Patterns
17import qualified Optimize.Patterns as Patterns
17import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
@@ -21,17 +22,25 @@ import qualified Reporting.Region as R
21-- OPTIMIZE - turn a canonical module into a list of optimized defs
22-- OPTIMIZE - turn a canonical module into a list of optimized defs
22
23
23optimize :: Module.CanonicalModule -> Module.Optimized
24optimize :: Module.CanonicalModule -> Module.Optimized
24−optimize module_ =
25+optimize (Module.Module home _ _ _ _ body) =
25 let
26 let
26− home =
27− Module.name module_
28−
29 (defs, _) =
27 (defs, _) =
30− flattenLets [] (Module.program (Module.body module_))
28+ flattenLets [] (Module.program body)
29+
30+ variantInfo (_, tags) =
31+ let
32+ variants = length tags
33+ in
34+ map (\(tag, _) -> (Var.fromModule home tag, variants)) tags
35+
36+ variantDict =
37+ Module.datatypes body
38+ |> Map.elems
39+ |> concatMap variantInfo
40+ |> Map.fromList
41+ |> Map.insert (Var.builtin "_Tuple2") 1
31 in
42 in
32− State.evalState
33− (concat <$> mapM (optimizeDef (Just home)) defs)
43+ Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)
34− (Env.Env False 0)
35
44
36
45
37flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)
46flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)
@@ -55,13 +64,13 @@ optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expressio
55 case (ptrn, args) of
64 case (ptrn, args) of
56 (P.Var name, _ : _) ->
65 (P.Var name, _ : _) ->
57
66
58− do (Env.Env htc uid) <- State.get
67+ do htc <- Env.getTailCall
59− State.put (Env.Env False uid)
68+ Env.setTailCall False
60
69
61 (args, body) <- optimizeFunction (Just name) args rawBody
70 (args, body) <- optimizeFunction (Just name) args rawBody
62
71
63− (Env.Env isTailCall uid') <- State.get
72+ isTailCall <- Env.getTailCall
64− State.put (Env.Env htc uid')
73+ Env.setTailCall htc
65
74
66 let facts = Opt.Facts home deps
75 let facts = Opt.Facts home deps
67
76
@@ -76,7 +85,7 @@ optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expressio
76
85
77 (P.Var name, []) ->
86 (P.Var name, []) ->
78
87
79− do hasTailCall <- State.gets Env._hasTailCall
88+ do hasTailCall <- Env.getTailCall
80 body <- optimizeExpr Nothing rawBody
89 body <- optimizeExpr Nothing rawBody
81 Env.setTailCall hasTailCall
90 Env.setTailCall hasTailCall
82 return [ Opt.Def (Opt.Facts home deps) name body ]
91 return [ Opt.Def (Opt.Facts home deps) name body ]
@@ -231,7 +240,7 @@ optimizeExpr context annExpr@(A.A region expression) =
231 return (Opt.TailCall name argNames optArgs)
240 return (Opt.TailCall name argNames optArgs)
232
241
233 Nothing ->
242 Nothing ->
234− do hasTailCall <- State.gets Env._hasTailCall
243+ do hasTailCall <- Env.getTailCall
235 optFunc <- justConvert func
244 optFunc <- justConvert func
236 optArgs <- T.traverse justConvert args
245 optArgs <- T.traverse justConvert args
237 Env.setTailCall hasTailCall
246 Env.setTailCall hasTailCall
@@ -253,7 +262,8 @@ optimizeExpr context annExpr@(A.A region expression) =
253 Expr.Case expr branches ->
262 Expr.Case expr branches ->
254 do optExpr <- optimizeExpr Nothing expr
263 do optExpr <- optimizeExpr Nothing expr
255 optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches
264 optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches
265+ variantDict <- Env.getVariantDict
256− Patterns.optimize region optExpr optBranches
266+ Patterns.optimize variantDict region optExpr optBranches
257
267
258 Expr.Data name exprs ->
268 Expr.Data name exprs ->
259 Opt.Data name <$> T.traverse justConvert exprs
269 Opt.Data name <$> T.traverse justConvert exprs
src/Optimize/Environment.hs+29−5
@@ -1,26 +1,50 @@
1−module Optimize.Environment where
1+module Optimize.Environment
2+ ( Optimizer, run
3+ , Env
4+ , getVariantDict
5+ , getTailCall, setTailCall
6+ , freshName
7+ ) where
2
8
3import qualified Control.Monad.State as State
9import qualified Control.Monad.State as State
4
10
11+import qualified Optimize.Patterns.DecisionTree as DT
12+
5
13
6type Optimizer a =
14type Optimizer a =
7 State.State Env a
15 State.State Env a
8
16
9
17
18+run :: DT.VariantDict -> Optimizer a -> a
19+run variantDict optimizer =
20+ State.evalState optimizer (Env False 0 variantDict)
21+
22+
10data Env = Env
23data Env = Env
11 { _hasTailCall :: Bool
24 { _hasTailCall :: Bool
12 , _uid :: Int
25 , _uid :: Int
26+ , _variantDict :: DT.VariantDict
13 }
27 }
14
28
15
29
30+getVariantDict :: Optimizer DT.VariantDict
31+getVariantDict =
32+ State.gets _variantDict
33+
34+
35+getTailCall :: Optimizer Bool
36+getTailCall =
37+ State.gets _hasTailCall
38+
39+
16setTailCall :: Bool -> Optimizer ()
40setTailCall :: Bool -> Optimizer ()
17setTailCall bool =
41setTailCall bool =
18− do uid <- State.gets _uid
42+ do env <- State.get
19− State.put (Env bool uid)
43+ State.put (env { _hasTailCall = bool })
20
44
21
45
22freshName :: Optimizer String
46freshName :: Optimizer String
23freshName =
47freshName =
24− do (Env htc uid) <- State.get
48+ do (Env htc uid vd) <- State.get
25− State.put (Env htc (uid + 1))
49+ State.put (Env htc (uid + 1) vd)
26 return ("_p" ++ show uid)
50 return ("_p" ++ show uid)
src/Optimize/Patterns.hs+14−15
@@ -1,20 +1,13 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Optimize.Patterns (optimize) where
2module Optimize.Patterns (optimize) where
3
3
4−import Control.Applicative
5import Control.Arrow (second)
4import Control.Arrow (second)
6−import qualified Control.Monad as M
7−import qualified Control.Monad.State as State
8import qualified Data.Map as Map
5import qualified Data.Map as Map
9import Data.Map ((!))
6import Data.Map ((!))
10import qualified Data.Maybe as Maybe
7import qualified Data.Maybe as Maybe
11−import qualified Data.Traversable as T
12
8
13import qualified AST.Expression.Optimized as Opt
9import qualified AST.Expression.Optimized as Opt
14−import qualified AST.Module as Module
15−import qualified AST.Module.Name as ModuleName
16import qualified AST.Pattern as P
10import qualified AST.Pattern as P
17−import qualified AST.Variable as Var
18import Elm.Utils ((|>))
11import Elm.Utils ((|>))
19import qualified Optimize.Environment as Env
12import qualified Optimize.Environment as Env
20import qualified Optimize.Patterns.DecisionTree as DT
13import qualified Optimize.Patterns.DecisionTree as DT
@@ -23,11 +16,12 @@ import qualified Reporting.Region as R
23
16
24
17
25optimize
18optimize
19+ :: DT.VariantDict
26− :: R.Region
20+ -> R.Region
27 -> Opt.Expr
21 -> Opt.Expr
28 -> [(P.CanonicalPattern, Opt.Expr)]
22 -> [(P.CanonicalPattern, Opt.Expr)]
29 -> Env.Optimizer Opt.Expr
23 -> Env.Optimizer Opt.Expr
30−optimize region optExpr optBranches =
24+optimize variantDict region optExpr optBranches =
31 let
25 let
32 indexify index (pattern, branch) =
26 indexify index (pattern, branch) =
33 ( (pattern, index)
27 ( (pattern, index)
@@ -49,17 +43,22 @@ optimize region optExpr optBranches =
49 unzip (zipWith indexify [0..] crashBranches)
43 unzip (zipWith indexify [0..] crashBranches)
50
44
51 let decisionTree =
45 let decisionTree =
52− DT.compile (error "need a VariantDict") patterns
46+ DT.compile variantDict patterns
53
47
48+ tempName <- Env.freshName
49+
50+ return $
51+ Opt.Let
52+ [ Opt.Def Opt.dummyFacts tempName optExpr ]
54− return (inlinedCase optExpr decisionTree indexedBranches)
53+ (inlinedCase tempName decisionTree indexedBranches)
55
54
56
55
57inlinedCase
56inlinedCase
58− :: Opt.Expr
57+ :: String
59 -> DT.DecisionTree DT.Jump
58 -> DT.DecisionTree DT.Jump
60 -> [(Int, Opt.Expr)]
59 -> [(Int, Opt.Expr)]
61 -> Opt.Expr
60 -> Opt.Expr
62−inlinedCase expr decisionTree jumpTargets =
61+inlinedCase name decisionTree jumpTargets =
63 let
62 let
64 substitutionDict =
63 substitutionDict =
65 gatherSubstitutions decisionTree
64 gatherSubstitutions decisionTree
@@ -68,7 +67,7 @@ inlinedCase expr decisionTree jumpTargets =
68 unzip (map (toJumps substitutionDict) jumpTargets)
67 unzip (map (toJumps substitutionDict) jumpTargets)
69 in
68 in
70 Opt.Case
69 Opt.Case
71− expr
70+ name
72 (inlineJumps (Map.fromList jumps) decisionTree)
71 (inlineJumps (Map.fromList jumps) decisionTree)
73 (Maybe.catMaybes sharedBranches)
72 (Maybe.catMaybes sharedBranches)
74
73
@@ -122,4 +121,4 @@ inlineJumps jumpDict decisionTree =
122 DT.Decision test (map (second go) edges) (fmap go fallback)
121 DT.Decision test (map (second go) edges) (fmap go fallback)
123
122
124 DT.Match (DT.Jump target _) ->
123 DT.Match (DT.Jump target _) ->
125− DT.Match (jumpDict ! target)
124+ DT.Match (jumpDict ! target)