@@ -8,14 +8,6 @@ list of patterns and expressions, and then turn that into a "decision tree"
88that requires as few tests as possible to make it to a leaf. Read the paper, it
99explains this extraordinarily well! We are currently using the same heuristics
1010as SML/NJ to get nice trees.
11−
12−Users of this module will mainly interact with the 'compile' function which
13−takes some normal branches and gives out a decision tree that has "labels" at
14−all the leafs and a dictionary that maps these "labels" to the code that
15−should run.
16−
17−If 2 or more leaves point to the same label, we need to do some tricks in JS to
18−make that work nicely. When is JS getting goto?! ;)
1911-}
2012
2113
@@ -35,9 +27,18 @@ import qualified Reporting.Annotation as A
3527
3628-- COMPILE CASES
3729
30+{-| Users of this module will mainly interact with this function. It takes
31+some normal branches and gives out a decision tree that has "labels" at all
32+the leafs and a dictionary that maps these "labels" to the code that should
33+run.
34+
35+If 2 or more leaves point to the same label, we need to do some tricks in JS to
36+make that work nicely. When is JS getting goto?! ;) That is outside the scope
37+of this module though.
38+-}
3839compile
3940 :: VariantDict
40− -> [(OPattern, Opt.Expr)]
41+ -> [(P.Optimized, Opt.Expr)]
4142 -> (DecisionTree Int, Map.Map Int Opt.Expr)
4243compile variantDict rawBranches =
4344 let
@@ -54,12 +55,29 @@ compile variantDict rawBranches =
5455 )
5556
5657
58+{-| When a certain union type is defined, you specify a certain number of tags.
59+This helps us do a few optimizations:
60+
61+ * If there is only one possible tag, we can always skip checking what it is.
62+ Tuples are a common example of this.
63+ * If we use all possible tags, we can skip doing the last test. If we have
64+ checked N-1 of N tags, there is no need to test the Nth, we know its the
65+ one we want
66+
67+So this dictionary maps tags to the number of variants that exist, so it'll
68+contain things like [ ("Just", 2), ("Nothing", 2), ("_Tuple2", 1), ... ] which
69+we can use for these optimizations.
70+-}
71+type VariantDict =
72+ Map.Map Var.Canonical Int
73+
74+
5775-- DECISION TREES
5876
5977data DecisionTree a
60− = Test
78+ = Decision
6179 { _test :: Path
62− , _edges :: [(Tag, DecisionTree a)]
80+ , _edges :: [(Test, DecisionTree a)]
6381 , _default :: Maybe (DecisionTree a)
6482 }
6583 | Match
@@ -68,16 +86,12 @@ data DecisionTree a
6886 }
6987
7088
71−-- EDGE CHECKS
72−
73−data Tag
89+data Test
7490 = Constructor Var.Canonical
7591 | Literal L.Literal
7692 deriving (Eq, Ord)
7793
7894
79−-- PATHS
80−
8195data Path
8296 = Position Int Path
8397 | Field String Path
@@ -86,6 +100,8 @@ data Path
86100 deriving (Eq)
87101
88102
103+-- PATH HELPERS
104+
89105add :: Path -> Path -> Path
90106add path finalLink =
91107 case path of
@@ -102,7 +118,7 @@ add path finalLink =
102118 Field name (add subpath finalLink)
103119
104120
105−subPositions :: Path -> [OPattern] -> [(Path, OPattern)]
121+subPositions :: Path -> [P.Optimized] -> [(Path, P.Optimized)]
106122subPositions path patterns =
107123 zipWith
108124 (\index pattern -> (add path (Position index Empty), pattern))
@@ -110,31 +126,22 @@ subPositions path patterns =
110126 patterns
111127
112128
113−-- CREATE DECISION TREES
114−
129+-- ACTUALLY BUILD DECISION TREES
115130
116131data Branch =
117132 Branch
118133 { _goal :: Int
119− , _patterns :: [(Path, OPattern)]
134+ , _patterns :: [(Path, P.Optimized)]
120135 }
121136
122137
123−type OPattern = P.Optimized
124−
125−
126−type VariantDict = Map.Map Var.Canonical Int
127−
128−
129−-- BUILD A DECISION TREE
130−
131138toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Int
132139toDecisionTree variantDict rawBranches =
133140 let
134141 branches =
135− map (skipUselessPatterns variantDict) rawBranches
142+ map (flattenPatterns variantDict) rawBranches
136143 in
137− case isAllValiables branches of
144+ case checkForMatch branches of
138145 Just (goal, substitutions) ->
139146 Match goal substitutions
140147
@@ -143,14 +150,14 @@ toDecisionTree variantDict rawBranches =
143150 path =
144151 smallDefaults branches
145152
146− relevantTags =
153+ relevantTests =
147154 tagsAtPath path branches
148155
149156 allRawEdges =
150− map (edgesFor path branches) relevantTags
157+ map (edgesFor path branches) relevantTests
151158
152159 (rawEdges, unexplored) =
153− if isComplete variantDict relevantTags then
160+ if isComplete variantDict relevantTests then
154161 ( init allRawEdges
155162 , snd (last allRawEdges)
156163 )
@@ -168,35 +175,38 @@ toDecisionTree variantDict rawBranches =
168175 decisionTree
169176
170177 (_, []) ->
171− Test path edges Nothing
178+ Decision path edges Nothing
172179
173180 (_, _) ->
174− Test path edges (Just (toDecisionTree variantDict unexplored))
181+ Decision path edges (Just (toDecisionTree variantDict unexplored))
175182
176183
177−isComplete :: VariantDict -> [Tag] -> Bool
178−isComplete variantDict tags =
179− case head tags of
184+isComplete :: VariantDict -> [Test] -> Bool
185+isComplete variantDict tests =
186+ case head tests of
180187 Constructor name ->
181− (variantDict ! name) == length tags
188+ (variantDict ! name) == length tests
182189
183190 Literal (L.Boolean _) ->
184− length tags == 2
191+ length tests == 2
185192
186193 _ ->
187194 False
188195
189196
190197
191−-- SKIP USELESS TESTS
198+-- FLATTEN PATTERNS
192199
193−skipUselessPatterns :: VariantDict -> Branch -> Branch
194−skipUselessPatterns variantDict (Branch goal pathPatterns) =
195− Branch goal (concatMap (skipper variantDict) pathPatterns)
200+{-| Flatten type aliases and use the VariantDict to figure out when a tag is
201+the only variant so we can skip doing any tests on it.
202+-}
203+flattenPatterns :: VariantDict -> Branch -> Branch
204+flattenPatterns variantDict (Branch goal pathPatterns) =
205+ Branch goal (concatMap (flatten variantDict) pathPatterns)
196206
197207
198−skipper :: VariantDict -> (Path, OPattern) -> [(Path, OPattern)]
199−skipper variantDict pathPattern@(path, A.A ann pattern) =
208+flatten :: VariantDict -> (Path, P.Optimized) -> [(Path, P.Optimized)]
209+flatten variantDict pathPattern@(path, A.A ann pattern) =
200210 case pattern of
201211 P.Var _ ->
202212 [pathPattern]
@@ -214,7 +224,7 @@ skipper variantDict pathPattern@(path, A.A ann pattern) =
214224
215225 P.Data tag patterns ->
216226 if variantDict ! tag == 1 then
217− concatMap (skipper variantDict) (subPositions path patterns)
227+ concatMap (flatten variantDict) (subPositions path patterns)
218228
219229 else
220230 [pathPattern]
@@ -223,10 +233,15 @@ skipper variantDict pathPattern@(path, A.A ann pattern) =
223233 [pathPattern]
224234
225235
226−-- VARIABLE SUBSTITUTIONS
236+-- SUCCESSFULLY MATCH
227237
228−isAllValiables :: [Branch] -> Maybe (Int, Map.Map String Path)
229−isAllValiables branches =
238+{-| If the first branch has no more "decision points" we can finally take that
239+path. If that is the case we give the resulting label and a mapping from free
240+variables to "how to get their value". So a pattern like (Just (x,_)) will give
241+us something like ("x" => value.0.0)
242+-}
243+checkForMatch :: [Branch] -> Maybe (Int, Map.Map String Path)
244+checkForMatch branches =
230245 case branches of
231246 Branch goal patterns : _ ->
232247 do subs <- concat `fmap` mapM getSubstitution patterns
@@ -236,7 +251,7 @@ isAllValiables branches =
236251 Nothing
237252
238253
239−getSubstitution :: (Path, OPattern) -> Maybe [(String, Path)]
254+getSubstitution :: (Path, P.Optimized) -> Maybe [(String, Path)]
240255getSubstitution (path, A.A _ pattern) =
241256 case pattern of
242257 P.Var x ->
@@ -258,15 +273,15 @@ getSubstitution (path, A.A _ pattern) =
258273 Nothing
259274
260275
261−-- FIND RELEVANT TAGS
276+-- FIND RELEVANT TESTS
262277
263−tagsAtPath :: Path -> [Branch] -> [Tag]
264−tagsAtPath selectedPath branches =
265− List.nub $ Maybe.mapMaybe (tagAtPath selectedPath) branches
278+testsAtPath :: Path -> [Branch] -> [Test]
279+testsAtPath selectedPath branches =
280+ List.nub $ Maybe.mapMaybe (testAtPath selectedPath) branches
266281
267282
268−tagAtPath :: Path -> Branch -> Maybe Tag
269−tagAtPath selectedPath (Branch _ pathPatterns) =
283+testAtPath :: Path -> Branch -> Maybe Test
284+testAtPath selectedPath (Branch _ pathPatterns) =
270285 case List.lookup selectedPath pathPatterns of
271286 Nothing ->
272287 Nothing
@@ -283,7 +298,7 @@ tagAtPath selectedPath (Branch _ pathPatterns) =
283298 Nothing
284299
285300 P.Alias _ _ ->
286− error "aliases should never reach 'tagAtPath' function"
301+ error "aliases should never reach 'testAtPath' function"
287302
288303 P.Anything ->
289304 Nothing
@@ -294,22 +309,22 @@ tagAtPath selectedPath (Branch _ pathPatterns) =
294309
295310-- BUILD EDGES
296311
297−edgesFor :: Path -> [Branch] -> Tag -> (Tag, [Branch])
298−edgesFor path branches tag =
299− ( tag
300− , Maybe.mapMaybe (subBranch tag path) branches
312+edgesFor :: Path -> [Branch] -> Test -> (Test, [Branch])
313+edgesFor path branches test =
314+ ( test
315+ , Maybe.mapMaybe (toRelevantBranch test path) branches
301316 )
302317
303318
304−subBranch :: Tag -> Path -> Branch -> Maybe Branch
305−subBranch tag path branch@(Branch goal pathPatterns) =
319+toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
320+toRelevantBranch test path branch@(Branch goal pathPatterns) =
306321 case extract path pathPatterns of
307322 Just (start, A.A _ pattern, end) ->
308323 case pattern of
309− P.Data name patterns | tag == Constructor name ->
324+ P.Data name patterns | test == Constructor name ->
310325 Just (Branch goal (start ++ subPositions path patterns ++ end))
311326
312− P.Literal lit | tag == Literal lit ->
327+ P.Literal lit | test == Literal lit ->
313328 Just (Branch goal (start ++ end))
314329
315330 _ ->
@@ -321,8 +336,8 @@ subBranch tag path branch@(Branch goal pathPatterns) =
321336
322337extract
323338 :: Path
324− -> [(Path, OPattern)]
325− -> Maybe ([(Path, OPattern)], OPattern, [(Path, OPattern)])
339+ -> [(Path, P.Optimized)]
340+ -> Maybe ([(Path, P.Optimized)], P.Optimized, [(Path, P.Optimized)])
326341extract selectedPath pathPatterns =
327342 case pathPatterns of
328343 [] ->
@@ -349,25 +364,30 @@ isIrrelevantTo selectedPath (Branch _ pathPatterns) =
349364 Nothing ->
350365 True
351366
352− Just (A.A _ pattern) ->
353− case pattern of
354− P.Var _ ->
355− True
367+ Just pattern ->
368+ not (needsTests pattern)
356369
357− P.Anything ->
358− True
359370
360− P.Alias _ _ ->
361− error "aliases should never reach 'isIrrelevantTo' function"
371+needsTests :: P.Optimized -> Bool
372+needsTests (A.A _ pattern) =
373+ case pattern of
374+ P.Var _ ->
375+ False
362376
363− P.Record _ ->
364− True
377+ P.Anything ->
378+ False
365379
366− P.Data _ _ ->
367− False
380+ P.Alias _ _ ->
381+ error "aliases should never reach 'isIrrelevantTo' function"
368382
369− P.Literal _ ->
370− False
383+ P.Record _ ->
384+ False
385+
386+ P.Data _ _ ->
387+ True
388+
389+ P.Literal _ ->
390+ True
371391
372392
373393-- PATH PICKING HEURISTICS
@@ -384,28 +404,12 @@ smallDefaults branches =
384404 fst (List.minimumBy (compare `on` snd) weightedPaths)
385405
386406
387−isChoicePath :: (Path, OPattern) -> Maybe Path
388−isChoicePath (path, A.A _ pattern) =
389− case pattern of
390− P.Var _ ->
391− Nothing
392−
393− P.Anything ->
394− Nothing
395−
396− P.Alias _ _ ->
397− error "aliases should never reach 'isChoicePath' function"
398−
399− P.Record _ ->
400− Nothing
401−
402− P.Data _ _ ->
403− Just path
404−
405− P.Literal _ ->
406− Just path
407+isChoicePath :: (Path, P.Optimized) -> Maybe Path
408+isChoicePath (path, pattern) =
409+ if needsTests pattern then
410+ Just path
411+ else
412+ Nothing
407413
408414
409415-- smallBranchingFactor :: [Branch] -> Path
410−
411−