97572f9 · elk · git.iko.soy

git.iko.soy/elk

Thread VariantDict through to decision tree compiler

commit97572f9c2ad1b8dc9e73d415caad9eb70bf77592 authorEvan Czaplicki <info@elm-lang.org> dateTue 8 Sep 2015, 22:29 (11 years ago) parent99a44a0

7 files changed+69−47

compare with master

unifiedsplit

src/AST/Module.hs+2−2 src/Compile.hs+12−5 src/Elm/Compiler.hs+2−4 src/Generate/JavaScript.hs+4−1 src/Nitpick/PatternMatches.hs+22−12 src/Optimize.hs+7−18 src/Optimize/Patterns/DecisionTree.hs+20−5

src/AST/Module.hs+2−2

@@ -60,7 +60,7 @@ type CanonicalModule =

6060

6161

6262type Optimized =

63− [Optimized.Def]

63+ Module Docs.Centralized [Name.Raw] [Var.Value] (Body [Optimized.Def])

6464

6565

6666data Module docs imports exports body = Module

@@ -124,7 +124,7 @@ data Interface = Interface

124124 }

125125

126126

127−toInterface :: Package.Name -> CanonicalModule -> Interface

127+toInterface :: Package.Name -> Optimized -> Interface

128128toInterface pkgName modul =

129129 let body' = body modul in

130130 Interface

src/Compile.hs+12−5

@@ -9,6 +9,7 @@ import Elm.Utils ((|>))

99import qualified Elm.Package as Package

1010import qualified Nitpick.PatternMatches as Nitpick

1111import qualified Nitpick.TopLevelTypes as Nitpick

12+import qualified Optimize

1213import qualified Parse.Helpers as Parse

1314import qualified Parse.Parse as Parse

1415import qualified Reporting.Error as Error

@@ -23,7 +24,7 @@ compile

2324 -> [ModuleName.Canonical]

2425 -> Module.Interfaces

2526 -> String

26− -> Result.Result Warning.Warning Error.Error Module.CanonicalModule

27+ -> Result.Result Warning.Warning Error.Error Module.Optimized

2728

2829compile packageName isRoot canonicalImports interfaces source =

2930 do

@@ -45,13 +46,19 @@ compile packageName isRoot canonicalImports interfaces source =

4546 Result.mapError Error.Type $

4647 Nitpick.topLevelTypes types (Module.body validModule)

4748

48− Result.mapError Error.Pattern $

49− Nitpick.patternMatches interfaces canonicalModule

49+ tagDict <-

50+ Result.mapError Error.Pattern $

51+ Nitpick.patternMatches interfaces canonicalModule

5052

5153 -- Add the real list of types

52− let body = (Module.body canonicalModule) { Module.types = types }

54+ let body =

55+ (Module.body canonicalModule) { Module.types = types }

5356

54− return $ canonicalModule { Module.body = body }

57+ -- Do some basic optimizations

58+ let optModule =

59+ Optimize.optimize tagDict (canonicalModule { Module.body = body })

60+

61+ return optModule

5562

5663

5764getOpTable :: Module.Interfaces -> Parse.OpTable

src/Elm/Compiler.hs+2−4

@@ -20,7 +20,6 @@ import qualified Elm.Compiler.Module as PublicModule

2020import qualified Elm.Docs as Docs

2121import qualified Elm.Package as Package

2222import qualified Generate.JavaScript as JS

23−import qualified Optimize

2423import qualified Parse.Module as Parse

2524import qualified Parse.Parse as Parse

2625import qualified Reporting.Annotation as A

@@ -77,8 +76,7 @@ compile context source interfaces =

7776 docs <- docsGen isExposed modul

7877

7978 let interface = Module.toInterface packageName modul

80− let optModule = Optimize.optimize modul

81− let javascript = JS.generate optModule

79+ let javascript = JS.generate modul

8280

8381 return (Result docs interface javascript)

8482 in

@@ -105,7 +103,7 @@ data Result = Result

105103

106104docsGen

107105 :: Bool

108− -> Module.CanonicalModule

106+ -> Module.Optimized

109107 -> Result.Result w Error.Error (Maybe Docs.Documentation)

110108docsGen isExposed modul =

111109 if not isExposed then

src/Generate/JavaScript.hs+4−1

@@ -24,8 +24,11 @@ import qualified Optimize.Patterns.DecisionTree as DT

2424

2525

2626generate :: Module.Optimized -> String

27−generate definitions =

27+generate module_ =

2828 let

29+ definitions =

30+ Module.program (Module.body module_)

31+

2932 stmts =

3033 State.evalState (mapM generateDef definitions) 0

3134 in

src/Nitpick/PatternMatches.hs+22−12

@@ -16,6 +16,7 @@ import qualified AST.Pattern as Pattern

1616import qualified AST.Variable as Var

1717import Elm.Utils ((|>))

1818import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)

19+import qualified Optimize.Patterns.DecisionTree as Opt

1920import qualified Reporting.Annotation as A

2021import qualified Reporting.Error.Pattern as Error

2122import qualified Reporting.Region as Region

@@ -25,31 +26,40 @@ import qualified Reporting.Result as Result

2526patternMatches

2627 :: Module.Interfaces

2728 -> Module.CanonicalModule

28− -> Result.Result w Error.Error ()

29+ -> Result.Result w Error.Error Opt.VariantDict

2930patternMatches interfaces modul =

3031 let

3132 name = Module.name modul

3233 body = Module.body modul

34+ tagDict =

35+ toTagDict interfaces name (Module.datatypes body)

3336 in

34− checkExpression

35− (toTagDict interfaces name (Module.datatypes body))

36− (Module.program body)

37+ const (Map.map (Map.map length) tagDict)

38+ <$> checkExpression tagDict (Module.program body)

3739

3840

3941-- TAG DICT

4042

4143type TagDict =

42− Map.Map Var.Home (Map.Map Tag [(Tag, Int)])

44+ Map.Map Var.Home (Map.Map Tag [TagInfo])

4345

4446

4547type Tag = String

4648

4749

50+data TagInfo = TagInfo

51+ { _tag :: Tag

52+ , _arity :: Int

53+ }

54+

55+

4856toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict

4957toTagDict interfaces localName localAdts =

5058 let

5159 listTags =

52− [ ("::", 2), ("[]", 0) ]

60+ [ TagInfo "::" 2

61+ , TagInfo "[]" 0

62+ ]

5363

5464 builtinDict =

5565 Map.singleton Var.BuiltIn $

@@ -67,12 +77,12 @@ toTagDict interfaces localName localAdts =

6777 Map.union builtinDict interfaceDict

6878

6979

70−toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])

80+toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]

7181toTagMapping adts =

7282 let

7383 toTagAndArity (_tvars, tagInfoList) =

7484 let

75− info = map (\(tag, args) -> (tag, length args)) tagInfoList

85+ info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList

7686 in

7787 map (second (const info)) tagInfoList

7888 in

@@ -81,7 +91,7 @@ toTagMapping adts =

8191 |> Map.fromList

8292

8393

84−lookupOtherTags :: Var.Canonical -> TagDict -> [(Tag, Int)]

94+lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]

8595lookupOtherTags (Var.Canonical home name) tagDict =

8696 case Map.lookup name =<< Map.lookup home tagDict of

8797 Just otherTags ->

@@ -89,7 +99,7 @@ lookupOtherTags (Var.Canonical home name) tagDict =

8999

90100 Nothing ->

91101 if Help.isTuple name then

92− [(name, read (drop 6 name))]

102+ [ TagInfo name (read (drop 6 name)) ]

93103 else

94104 error

95105 "Since the Nitpick phase happens after canonicalization and type \

@@ -339,8 +349,8 @@ complementData tagDict tag patterns =

339349 tagComplements ++ argComplements

340350

341351

342−tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern

343−tagToPattern (Var.Canonical home rootTag) (tag, arity) =

352+tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern

353+tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =

344354 if rootTag == tag then

345355 Nothing

346356 else

src/Optimize.hs+7−18

@@ -2,7 +2,6 @@ module Optimize (optimize) where

33import Control.Applicative

44import qualified Control.Monad as M

5−import qualified Data.Map as Map

65import qualified Data.Traversable as T

87import qualified AST.Expression.General as Expr

@@ -12,35 +11,25 @@ import qualified AST.Module as Module

1211import qualified AST.Module.Name as ModuleName

1312import qualified AST.Pattern as P

1413import qualified AST.Variable as Var

15−import Elm.Utils ((|>))

1614import qualified Optimize.Environment as Env

1715import qualified Optimize.Patterns as Patterns

16+import qualified Optimize.Patterns.DecisionTree as DT

1817import qualified Reporting.Annotation as A

1918import qualified Reporting.Region as R

2019

2120

22−-- OPTIMIZE - turn a canonical module into a list of optimized defs

21+-- OPTIMIZE

2322

24−optimize :: Module.CanonicalModule -> Module.Optimized

25−optimize (Module.Module home _ _ _ _ body) =

23+optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized

24+optimize variantDict module_@(Module.Module home _ _ _ _ body) =

2625 let

2726 (defs, _) =

2827 flattenLets [] (Module.program body)

2928

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

29+ optDefs =

30+ Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

4231 in

43− Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

32+ module_ { Module.body = body { Module.program = optDefs } }

4433

4534

4635flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

src/Optimize/Patterns/DecisionTree.hs+20−5

@@ -16,9 +16,9 @@ import Data.Function (on)

1616import qualified Data.List as List

1717import qualified Data.Map as Map

1818import qualified Data.Set as Set

19−import Data.Map ((!))

2019import qualified Data.Maybe as Maybe

2120

21+import qualified AST.Helpers as Help

2222import qualified AST.Literal as L

2323import qualified AST.Pattern as P

2424import qualified AST.Variable as Var

@@ -62,7 +62,7 @@ contain things like [ ("Just", 2), ("Nothing", 2), ("_Tuple2", 1), ... ] which

6262we can use for these optimizations.

6363-}

6464type VariantDict =

65− Map.Map Var.Canonical Int

65+ Map.Map Var.Home (Map.Map String Int)

6666

6767

6868-- DECISION TREES

@@ -180,8 +180,8 @@ toDecisionTree variantDict rawBranches =

180180isComplete :: VariantDict -> [Test] -> Bool

181181isComplete variantDict tests =

182182 case head tests of

183− Constructor name ->

184− (variantDict ! name) == length tests

183+ Constructor var ->

184+ getArity variantDict var == length tests

185185

186186 Literal (L.Boolean _) ->

187187 length tests == 2

@@ -190,6 +190,21 @@ isComplete variantDict tests =

190190 False

191191

192192

193+getArity :: VariantDict -> Var.Canonical -> Int

194+getArity variantDict (Var.Canonical home name) =

195+ case Map.lookup name =<< Map.lookup home variantDict of

196+ Just arity ->

197+ arity

198+

199+ Nothing ->

200+ if Help.isTuple name then

201+ read (drop 6 name)

202+

203+ else

204+ error

205+ "Since the Optimize phase happens after canonicalization and type \

206+ \inference, it is impossible that a pattern cannot be found."

207+

193208

194209-- FLATTEN PATTERNS

195210

@@ -219,7 +234,7 @@ flatten variantDict pathPattern@(path, A.A ann pattern) =

219234 [pathPattern]

220235

221236 P.Data tag patterns ->

222− if variantDict ! tag == 1 then

237+ if getArity variantDict tag == 1 then

223238 concatMap (flatten variantDict) (subPositions path patterns)

224239

225240 else