git.iko.soy/elk
on master help sign in
Handle enums and boxed values in optimized AST

The main thing that was tricky here was that the way I destructured patterns needed to change. Because someone may destructure an argument like (Parser k) where in PROD it should not turn into a _v4.a access. There will be no box! I also treat lists a bit special so I can generate a.b to test if we are looking at a CONS cell. This works because a.b will be an object in CONS cells, which turns into true in JS, and it will be undefined in a NIL, which is false in JS.

commit833ed96040f505187e37ecdf8c597e0689dd070c authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 12 Jan 2018, 16:22 (9 years ago) parenta740aac
6 files changed+323−247
compare with master
unifiedsplit
src/AST/Optimized.hs+107−59 src/Optimize/DecisionTree.hs+92−94 src/Optimize/Expression.hs+68−65 src/Optimize/Module.hs+8−9 src/Optimize/Names.hs+26 src/Optimize/Port.hs+22−20
src/AST/Optimized.hs+107−59
@@ -4,6 +4,8 @@ module AST.Optimized
44 , Expr(..)
55 , Global(..)
66 , kernel
7+ , Path(..)
8+ , Destructor(..)
79 , Decider(..)
810 , Choice(..)
911 , Graph(..)
@@ -43,6 +45,8 @@ data Expr
4345 | Float Double
4446 | VarLocal N.Name
4547 | VarGlobal Global
48+ | VarEnum Global Index.ZeroBased
49+ | VarBox Global
4650 | VarCycle ModuleName.Canonical N.Name
4751 | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
4852 | VarKernel N.Name N.Name
@@ -52,8 +56,8 @@ data Expr
5256 | TailCall N.Name [(N.Name, Expr)]
5357 | If [(Expr, Expr)] Expr
5458 | Let Def Expr
59+ | Destruct Destructor Expr
5560 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
56− | Index Expr Int
5761 | Accessor N.Name
5862 | Access Expr N.Name
5963 | Update Expr (Map.Map N.Name Expr)
@@ -83,6 +87,17 @@ data Def
8387 | TailDef N.Name [N.Name] Expr
8488
8589
90+data Destructor =
91+ Destructor N.Name Path
92+
93+
94+data Path
95+ = Index Index.ZeroBased Path
96+ | Field N.Name Path
97+ | Unbox Path
98+ | Root N.Name
99+
100+
86101
87102-- BRANCHING
88103
@@ -131,6 +146,8 @@ data Node
131146 = Define Expr (Set.Set Global)
132147 | DefineTailFunc [N.Name] Expr (Set.Set Global)
133148 | Ctor N.Name Index.ZeroBased Int
149+ | Enum N.Name Index.ZeroBased
150+ | Box N.Name
134151 | Link Global
135152 | Cycle [(N.Name, Expr)] (Set.Set Global)
136153 | Manager EffectsType
@@ -152,7 +169,7 @@ data KChunk
152169 | JsVar N.Name N.Name
153170 | ElmField N.Name
154171 | JsField Int
155− | Enum Int
172+ | JsEnum Int
156173 | Debug
157174 | Prod
158175
@@ -175,24 +192,26 @@ instance Binary Expr where
175192 Float a -> putWord8 3 >> put a
176193 VarLocal a -> putWord8 4 >> put a
177194 VarGlobal a -> putWord8 5 >> put a
178− VarCycle a b -> putWord8 6 >> put a >> put b
179− VarDebug a b c d -> putWord8 7 >> put a >> put b >> put c >> put d
180− VarKernel a b -> putWord8 8 >> put a >> put b
181− List a -> putWord8 9 >> put a
182− Function a b -> putWord8 10 >> put a >> put b
183− Call a b -> putWord8 11 >> put a >> put b
184− TailCall a b -> putWord8 12 >> put a >> put b
185− If a b -> putWord8 13 >> put a >> put b
186− Let a b -> putWord8 14 >> put a >> put b
187− Case a b c d -> putWord8 15 >> put a >> put b >> put c >> put d
188− Index a b -> putWord8 16 >> put a >> put b
189− Accessor a -> putWord8 17 >> put a
190− Access a b -> putWord8 18 >> put a >> put b
191− Update a b -> putWord8 19 >> put a >> put b
192− Record a -> putWord8 20 >> put a
193− Unit -> putWord8 21
194− Tuple a b c -> putWord8 22 >> put a >> put b >> put c
195− Shader a -> putWord8 23 >> put a
195+ VarEnum a b -> putWord8 6 >> put a >> put b
196+ VarBox a -> putWord8 7 >> put a
197+ VarCycle a b -> putWord8 8 >> put a >> put b
198+ VarDebug a b c d -> putWord8 9 >> put a >> put b >> put c >> put d
199+ VarKernel a b -> putWord8 10 >> put a >> put b
200+ List a -> putWord8 11 >> put a
201+ Function a b -> putWord8 12 >> put a >> put b
202+ Call a b -> putWord8 13 >> put a >> put b
203+ TailCall a b -> putWord8 14 >> put a >> put b
204+ If a b -> putWord8 15 >> put a >> put b
205+ Let a b -> putWord8 16 >> put a >> put b
206+ Destruct a b -> putWord8 17 >> put a >> put b
207+ Case a b c d -> putWord8 18 >> put a >> put b >> put c >> put d
208+ Accessor a -> putWord8 19 >> put a
209+ Access a b -> putWord8 20 >> put a >> put b
210+ Update a b -> putWord8 21 >> put a >> put b
211+ Record a -> putWord8 22 >> put a
212+ Unit -> putWord8 23
213+ Tuple a b c -> putWord8 24 >> put a >> put b >> put c
214+ Shader a -> putWord8 25 >> put a
196215
197216 get =
198217 do word <- getWord8
@@ -203,24 +222,26 @@ instance Binary Expr where
203222 3 -> liftM Float get
204223 4 -> liftM VarLocal get
205224 5 -> liftM VarGlobal get
206− 6 -> liftM2 VarCycle get get
207− 7 -> liftM4 VarDebug get get get get
208− 8 -> liftM2 VarKernel get get
209− 9 -> liftM List get
210− 10 -> liftM2 Function get get
211− 11 -> liftM2 Call get get
212− 12 -> liftM2 TailCall get get
213− 13 -> liftM2 If get get
214− 14 -> liftM2 Let get get
215− 15 -> liftM4 Case get get get get
216− 16 -> liftM2 Index get get
217− 17 -> liftM Accessor get
218− 18 -> liftM2 Access get get
219− 19 -> liftM2 Update get get
220− 20 -> liftM Record get
221− 21 -> pure Unit
222− 22 -> liftM3 Tuple get get get
223− 23 -> liftM Shader get
225+ 6 -> liftM2 VarEnum get get
226+ 7 -> liftM VarBox get
227+ 8 -> liftM2 VarCycle get get
228+ 9 -> liftM4 VarDebug get get get get
229+ 10 -> liftM2 VarKernel get get
230+ 11 -> liftM List get
231+ 12 -> liftM2 Function get get
232+ 13 -> liftM2 Call get get
233+ 14 -> liftM2 TailCall get get
234+ 15 -> liftM2 If get get
235+ 16 -> liftM2 Let get get
236+ 17 -> liftM2 Destruct get get
237+ 18 -> liftM4 Case get get get get
238+ 19 -> liftM Accessor get
239+ 20 -> liftM2 Access get get
240+ 21 -> liftM2 Update get get
241+ 22 -> liftM Record get
242+ 23 -> pure Unit
243+ 24 -> liftM3 Tuple get get get
244+ 25 -> liftM Shader get
224245 _ -> error "problem getting Opt.Expr binary"
225246
226247
@@ -238,6 +259,29 @@ instance Binary Def where
238259 _ -> error "problem getting Opt.Def binary"
239260
240261
262+instance Binary Destructor where
263+ get = liftM2 Destructor get get
264+ put (Destructor a b) = put a >> put b
265+
266+
267+instance Binary Path where
268+ put destructor =
269+ case destructor of
270+ Index a b -> putWord8 0 >> put a >> put b
271+ Field a b -> putWord8 1 >> put a >> put b
272+ Unbox a -> putWord8 2 >> put a
273+ Root a -> putWord8 3 >> put a
274+
275+ get =
276+ do word <- getWord8
277+ case word of
278+ 0 -> liftM2 Index get get
279+ 1 -> liftM2 Field get get
280+ 2 -> liftM Unbox get
281+ 3 -> liftM Root get
282+ _ -> error "problem getting Opt.Path binary"
283+
284+
241285instance (Binary a) => Binary (Decider a) where
242286 put decider =
243287 case decider of
@@ -291,29 +335,33 @@ instance Binary Main where
291335instance Binary Node where
292336 put node =
293337 case node of
294− Define a b -> putWord8 0 >> put a >> put b
295− DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
296− Ctor a b c -> putWord8 2 >> put a >> put b >> put c
297− Link a -> putWord8 3 >> put a
298− Cycle a b -> putWord8 4 >> put a >> put b
299− Manager a -> putWord8 5 >> put a
300− Kernel a b -> putWord8 6 >> put a >> put b
301− PortIncoming a b -> putWord8 7 >> put a >> put b
302− PortOutgoing a b -> putWord8 8 >> put a >> put b
338+ Define a b -> putWord8 0 >> put a >> put b
339+ DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
340+ Ctor a b c -> putWord8 2 >> put a >> put b >> put c
341+ Enum a b -> putWord8 3 >> put a >> put b
342+ Box a -> putWord8 4 >> put a
343+ Link a -> putWord8 5 >> put a
344+ Cycle a b -> putWord8 6 >> put a >> put b
345+ Manager a -> putWord8 7 >> put a
346+ Kernel a b -> putWord8 8 >> put a >> put b
347+ PortIncoming a b -> putWord8 9 >> put a >> put b
348+ PortOutgoing a b -> putWord8 10 >> put a >> put b
303349
304350 get =
305351 do word <- getWord8
306352 case word of
307− 0 -> liftM2 Define get get
308− 1 -> liftM3 DefineTailFunc get get get
309− 2 -> liftM3 Ctor get get get
310− 3 -> liftM Link get
311− 4 -> liftM2 Cycle get get
312− 5 -> liftM Manager get
313− 6 -> liftM2 Kernel get get
314− 7 -> liftM2 PortIncoming get get
315− 8 -> liftM2 PortOutgoing get get
316− _ -> error "problem getting Opt.Node binary"
353+ 0 -> liftM2 Define get get
354+ 1 -> liftM3 DefineTailFunc get get get
355+ 2 -> liftM3 Ctor get get get
356+ 3 -> liftM2 Enum get get
357+ 4 -> liftM Box get
358+ 5 -> liftM Link get
359+ 6 -> liftM2 Cycle get get
360+ 7 -> liftM Manager get
361+ 8 -> liftM2 Kernel get get
362+ 9 -> liftM2 PortIncoming get get
363+ 10 -> liftM2 PortOutgoing get get
364+ _ -> error "problem getting Opt.Node binary"
317365
318366
319367instance Binary EffectsType where
@@ -345,7 +393,7 @@ instance Binary KChunk where
345393 JsVar a b -> putWord8 2 >> put a >> put b
346394 ElmField a -> putWord8 3 >> put a
347395 JsField a -> putWord8 4 >> put a
348− Enum a -> putWord8 5 >> put a
396+ JsEnum a -> putWord8 5 >> put a
349397 Debug -> putWord8 6
350398 Prod -> putWord8 7
351399
@@ -357,7 +405,7 @@ instance Binary KChunk where
357405 2 -> liftM2 JsVar get get
358406 3 -> liftM ElmField get
359407 4 -> liftM JsField get
360− 5 -> liftM Enum get
408+ 5 -> liftM JsEnum get
361409 6 -> return Debug
362410 7 -> return Prod
363411 _ -> error "problem deserializing AST.Optimized.KChunk"
src/Optimize/DecisionTree.hs+92−94
@@ -21,7 +21,7 @@ as SML/NJ to get nice trees.
2121-}
2222
2323import Control.Arrow (second)
24−import Control.Monad (liftM, liftM2, liftM3)
24+import Control.Monad (liftM, liftM2, liftM4)
2525import Data.Binary
2626import qualified Data.List as List
2727import qualified Data.Maybe as Maybe
@@ -71,7 +71,9 @@ data DecisionTree
7171
7272
7373data Test
74− = IsCtor Int N.Name Index.ZeroBased
74+ = IsCtor N.Name Index.ZeroBased Int Can.CtorOpts
75+ | IsCons
76+ | IsNil
7577 | IsInt Int
7678 | IsChr Text
7779 | IsStr Text
@@ -79,42 +81,13 @@ data Test
7981
8082
8183data Path
82− = Index Int Path
83− | Field N.Name Path
84+ = Index Index.ZeroBased Path
85+ | Unbox Path
8486 | Empty
85− | Alias
8687 deriving (Eq)
8788
8889
8990
90−-- PATH HELPERS
91−
92−
93−add :: Path -> Path -> Path
94−add path finalLink =
95− case path of
96− Empty ->
97− finalLink
98−
99− Alias ->
100− error "nothing should be added to an alias path"
101−
102− Index index subpath ->
103− Index index (add subpath finalLink)
104−
105− Field name subpath ->
106− Field name (add subpath finalLink)
107−
108−
109−subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]
110−subPositions path patterns =
111− zipWith
112− (\index pattern -> (add path (Index index Empty), pattern))
113− [0..]
114− patterns
115−
116−
117−
11891-- ACTUALLY BUILD DECISION TREES
11992
12093
@@ -163,8 +136,14 @@ toDecisionTree rawBranches =
163136isComplete :: [Test] -> Bool
164137isComplete tests =
165138 case head tests of
166− IsCtor alts _ _ ->
167− alts == length tests
139+ IsCtor _ _ numAlts _ ->
140+ numAlts == length tests
141+
142+ IsCons ->
143+ length tests == 2
144+
145+ IsNil ->
146+ length tests == 2
168147
169148 _ ->
170149 False
@@ -191,29 +170,32 @@ flatten pathPattern@(path, A.At region pattern) =
191170 Can.PAnything ->
192171 [pathPattern]
193172
194− Can.PAlias realPattern alias ->
195− (add path Alias, A.At region (Can.PVar alias))
196− :
197− flatten (path, realPattern)
198−
199− Can.PRecord _ ->
200− [pathPattern]
201−
202− Can.PUnit ->
203− [pathPattern]
204−
205173 Can.PTuple a b Nothing ->
206174 concatMap flatten (subPositions path [a,b])
207175
208176 Can.PTuple a b (Just c) ->
209177 concatMap flatten (subPositions path [a,b,c])
210178
211− Can.PCtor _ _ _ (Can.CtorAlts numAlts _) _ _ args ->
212− if numAlts == 1 then
213− concatMap flatten (subPositions path (map dearg args))
214− else
179+ Can.PCtor _ _ (Can.Union _ _ 1 _) _ _ ctorArgs ->
180+ case map dearg ctorArgs of
181+ [arg] ->
182+ flatten (Unbox path, arg)
183+
184+ args ->
185+ concatMap flatten (subPositions path args)
186+
187+ Can.PCtor _ _ _ _ _ _ ->
215188 [pathPattern]
216189
190+ Can.PAlias realPattern alias ->
191+ (path, A.At region (Can.PVar alias)) : flatten (path, realPattern)
192+
193+ Can.PRecord _ ->
194+ [pathPattern]
195+
196+ Can.PUnit ->
197+ [pathPattern]
198+
217199 Can.PList _ ->
218200 [pathPattern]
219201
@@ -230,6 +212,11 @@ flatten pathPattern@(path, A.At region pattern) =
230212 [pathPattern]
231213
232214
215+subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]
216+subPositions path patterns =
217+ Index.indexedMap (\index pattern -> (Index index path, pattern)) patterns
218+
219+
233220dearg :: Can.PatternCtorArg -> Can.Pattern
234221dearg (Can.PatternCtorArg _ _ pattern) =
235222 pattern
@@ -305,8 +292,8 @@ testAtPath selectedPath (Branch _ pathPatterns) =
305292
306293 Just (A.At _ pattern) ->
307294 case pattern of
308− Can.PCtor _ _ _ (Can.CtorAlts numAlts _) name index _ ->
309− Just (IsCtor numAlts name index)
295+ Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->
296+ Just (IsCtor name index numAlts opts)
310297
311298 Can.PInt int ->
312299 Just (IsInt int)
@@ -318,13 +305,13 @@ testAtPath selectedPath (Branch _ pathPatterns) =
318305 Just (IsChr chr)
319306
320307 Can.PList [] ->
321− Just nilTest
308+ Just IsNil
322309
323310 Can.PList _ ->
324− Just consTest
311+ Just IsCons
325312
326313 Can.PCons _ _ ->
327− Just consTest
314+ Just IsCons
328315
329316 Can.PVar _ ->
330317 Nothing
@@ -345,16 +332,6 @@ testAtPath selectedPath (Branch _ pathPatterns) =
345332 Nothing
346333
347334
348−{-# NOINLINE nilTest #-}
349−nilTest :: Test
350−nilTest = IsCtor 2 "[]" (Index.unsafe (-1))
351−
352−
353−{-# NOINLINE consTest #-}
354−consTest :: Test
355−consTest = IsCtor 2 "::" (Index.unsafe (-2))
356−
357−
358335
359336-- BUILD EDGES
360337
@@ -371,47 +348,66 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =
371348 case extract path pathPatterns of
372349 Just (start, A.At region pattern, end) ->
373350 case pattern of
374− Can.PCtor _ _ _ (Can.CtorAlts numAlts _) name index args ->
375− if test == IsCtor numAlts name index then
376− Just (Branch goal (start ++ subPositions path (map dearg args) ++ end))
377− else
351+ Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->
352+ case test of
353+ IsCtor testName _ _ _ | name == testName ->
354+ Just $ Branch goal $
355+ case map dearg ctorArgs of
356+ [arg] | numAlts == 1 ->
357+ start ++ [(Unbox path, arg)] ++ end
358+
359+ args ->
360+ start ++ subPositions path args ++ end
361+
362+ _ ->
378363 Nothing
379364
380365 Can.PList [] ->
381− if test == nilTest then
366+ case test of
367+ IsNil ->
382368 Just (Branch goal (start ++ end))
383− else
369+
370+ _ ->
384371 Nothing
385372
386373 Can.PList (hd:tl) ->
387− if test == consTest then
374+ case test of
375+ IsCons ->
388376 let tl' = A.At region (Can.PList tl) in
389377 Just (Branch goal (start ++ subPositions path [ hd, tl' ] ++ end))
390− else
378+
379+ _ ->
391380 Nothing
392381
393382 Can.PCons hd tl ->
394− if test == consTest then
383+ case test of
384+ IsCons ->
395385 Just (Branch goal (start ++ subPositions path [hd,tl] ++ end))
396− else
386+
387+ _ ->
397388 Nothing
398389
399390 Can.PChr chr ->
400− if test == IsChr chr then
391+ case test of
392+ IsChr testChr | chr == testChr ->
401393 Just (Branch goal (start ++ end))
402− else
394+ _ ->
403395 Nothing
404396
405397 Can.PStr str ->
406− if test == IsStr str then
398+ case test of
399+ IsStr testStr | str == testStr ->
407400 Just (Branch goal (start ++ end))
408− else
401+
402+ _ ->
409403 Nothing
410404
411405 Can.PInt int ->
412− if test == IsInt int then
406+ case test of
407+ IsInt testInt | int == testInt ->
413408 Just (Branch goal (start ++ end))
414− else
409+
410+ _ ->
415411 Nothing
416412
417413 _ ->
@@ -472,7 +468,7 @@ needsTests (A.At _ pattern) =
472468 Can.PRecord _ ->
473469 False
474470
475− Can.PCtor _ _ _ _ _ _ _ ->
471+ Can.PCtor _ _ _ _ _ _ ->
476472 True
477473
478474 Can.PList _ ->
@@ -574,18 +570,22 @@ smallBranchingFactor branches path =
574570instance Binary Test where
575571 put test =
576572 case test of
577− IsCtor a b c -> putWord8 0 >> put a >> put b >> put c
578− IsChr a -> putWord8 1 >> put a
579− IsStr a -> putWord8 2 >> put a
580− IsInt a -> putWord8 3 >> put a
573+ IsCtor a b c d -> putWord8 0 >> put a >> put b >> put c >> put d
574+ IsCons -> putWord8 1
575+ IsNil -> putWord8 2
576+ IsChr a -> putWord8 3 >> put a
577+ IsStr a -> putWord8 4 >> put a
578+ IsInt a -> putWord8 5 >> put a
581579
582580 get =
583581 do word <- getWord8
584582 case word of
585− 0 -> liftM3 IsCtor get get get
586− 1 -> liftM IsChr get
587− 2 -> liftM IsStr get
588− 3 -> liftM IsInt get
583+ 0 -> liftM4 IsCtor get get get get
584+ 1 -> pure IsCons
585+ 2 -> pure IsNil
586+ 3 -> liftM IsChr get
587+ 4 -> liftM IsStr get
588+ 5 -> liftM IsInt get
589589 _ -> error "problem getting DecisionTree.Test binary"
590590
591591
@@ -593,15 +593,13 @@ instance Binary Path where
593593 put path =
594594 case path of
595595 Index a b -> putWord8 0 >> put a >> put b
596− Field a b -> putWord8 1 >> put a >> put b
596+ Unbox a -> putWord8 1 >> put a
597597 Empty -> putWord8 2
598− Alias -> putWord8 3
599598
600599 get =
601600 do word <- getWord8
602601 case word of
603602 0 -> liftM2 Index get get
604− 1 -> liftM2 Field get get
603+ 1 -> liftM Unbox get
605604 2 -> pure Empty
606− 3 -> pure Alias
607605 _ -> error "problem getting DecisionTree.Path binary"
src/Optimize/Expression.hs+68−65
@@ -49,6 +49,9 @@ optimize cycle (A.At region expression) =
4949 Can.VarForeign home name _ ->
5050 Names.registerGlobal home name
5151
52+ Can.VarCtor opts home name index _ ->
53+ Names.registerCtor home name index opts
54+
5255 Can.VarDebug home name _ ->
5356 Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)
5457
@@ -82,9 +85,9 @@ optimize cycle (A.At region expression) =
8285 return (Opt.Call optFunc [optLeft, optRight])
8386
8487 Can.Lambda args body ->
85− do (argNames, defss) <- destructArgs args
88+ do (argNames, destructors) <- destructArgs args
8689 obody <- optimize cycle body
87− pure $ Opt.Function argNames (foldr Opt.Let obody (concat defss))
90+ pure $ Opt.Function argNames (foldr Opt.Destruct obody destructors)
8891
8992 Can.Call func args ->
9093 Opt.Call
@@ -117,18 +120,18 @@ optimize cycle (A.At region expression) =
117120 foldM (\bod def -> optimizeDef cycle def bod) obody defs
118121
119122 Can.LetDestruct pattern expr body ->
120− do (name, defs) <- destruct pattern
123+ do (name, destructs) <- destruct pattern
121124 oexpr <- optimize cycle expr
122125 obody <- optimize cycle body
123126 pure $
124− Opt.Let (Opt.Def name oexpr) (foldr Opt.Let obody defs)
127+ Opt.Let (Opt.Def name oexpr) (foldr Opt.Destruct obody destructs)
125128
126129 Can.Case expr branches ->
127130 let
128131 optimizeBranch root (Can.CaseBranch pattern branch) =
129− do defs <- destructHelp (Opt.VarLocal root) pattern []
132+ do destructors <- destructHelp (Opt.Root root) pattern []
130133 obranch <- optimize cycle branch
131− pure (pattern, foldr Opt.Let obranch defs)
134+ pure (pattern, foldr Opt.Destruct obranch destructors)
132135 in
133136 do temp <- Names.generate
134137 oexpr <- optimize cycle expr
@@ -190,8 +193,8 @@ optimizeDefHelp cycle name args expr body =
190193 pure $ Opt.Let (Opt.Def name oexpr) body
191194
192195 _ ->
193− do (argNames, defss) <- destructArgs args
194− let oexpr = Opt.Function argNames (foldr Opt.Let body (concat defss))
196+ do (argNames, destructors) <- destructArgs args
197+ let oexpr = Opt.Function argNames (foldr Opt.Destruct body destructors)
195198 pure $ Opt.Let (Opt.Def name oexpr) body
196199
197200
@@ -199,98 +202,98 @@ optimizeDefHelp cycle name args expr body =
199202-- DESTRUCTURING
200203
201204
202−destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [[Opt.Def]])
205+destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [Opt.Destructor])
203206destructArgs args =
204− unzip <$> traverse destruct args
207+ do (argNames, destructorLists) <- unzip <$> traverse destruct args
208+ return (argNames, concat destructorLists)
205209
206210
207−destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Def])
211+destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Destructor])
208212destruct pattern@(A.At _ ptrn) =
209213 case ptrn of
210214 Can.PVar name ->
211215 pure (name, [])
212216
213217 Can.PAlias subPattern name ->
214− do revDefs <- destructHelp (Opt.VarLocal name) subPattern []
215− pure (name, reverse revDefs)
218+ do revDs <- destructHelp (Opt.Root name) subPattern []
219+ pure (name, reverse revDs)
216220
217221 _ ->
218222 do name <- Names.generate
219− revDefs <- destructHelp (Opt.VarLocal name) pattern []
220− pure (name, reverse revDefs)
223+ revDs <- destructHelp (Opt.Root name) pattern []
224+ pure (name, reverse revDs)
221225
222226
223−destructHelp :: Opt.Expr -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
224−destructHelp root (A.At region pattern) revDefs =
227+destructHelp :: Opt.Path -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]
228+destructHelp path (A.At region pattern) revDs =
225229 case pattern of
226230 Can.PAnything ->
227− pure revDefs
231+ pure revDs
228232
229233 Can.PVar name ->
230− pure (Opt.Def name root : revDefs)
234+ pure (Opt.Destructor name path : revDs)
231235
232236 Can.PRecord fields ->
233− let toDef name = Opt.Def name (Opt.Access root name) in
234− Names.registerFieldList fields (map toDef fields ++ revDefs)
237+ let
238+ toDestruct name =
239+ Opt.Destructor name (Opt.Field name path)
240+ in
241+ Names.registerFieldList fields (map toDestruct fields ++ revDs)
235242
236243 Can.PAlias subPattern name ->
237− destructHelp (Opt.VarLocal name) subPattern $
238− Opt.Def name root : revDefs
244+ destructHelp (Opt.Root name) subPattern $
245+ Opt.Destructor name path : revDs
239246
240247 Can.PUnit ->
241− pure revDefs
248+ pure revDs
249+
250+ Can.PTuple a b Nothing ->
251+ destructTwo path a b revDs
242252
243− Can.PTuple a b maybeC ->
253+ Can.PTuple a b (Just c) ->
244254 do name <- Names.generate
245− let tuple = Opt.VarLocal name
246− let newRevDefs = Opt.Def name root : revDefs
247− case maybeC of
248− Nothing ->
249− destructHelp (Opt.Index tuple 1) b =<<
250− destructHelp (Opt.Index tuple 0) a newRevDefs
251−
252− Just c ->
253− destructHelp (Opt.Index tuple 2) c =<<
254− destructHelp (Opt.Index tuple 1) b =<<
255− destructHelp (Opt.Index tuple 0) a newRevDefs
255+ let newRoot = Opt.Root name
256+ destructHelp (Opt.Index Index.first newRoot) a =<<
257+ destructHelp (Opt.Index Index.second newRoot) b =<<
258+ destructHelp (Opt.Index Index.third newRoot) c (Opt.Destructor name path : revDs)
256259
257260 Can.PList [] ->
258− pure revDefs
261+ pure revDs
259262
260263 Can.PList (hd:tl) ->
261− destructCons root hd (A.At region (Can.PList tl)) revDefs
264+ destructTwo path hd (A.At region (Can.PList tl)) revDs
262265
263266 Can.PCons hd tl ->
264− destructCons root hd tl revDefs
267+ destructTwo path hd tl revDs
265268
266269 Can.PChr _ ->
267− pure revDefs
270+ pure revDs
268271
269272 Can.PStr _ ->
270− pure revDefs
273+ pure revDs
271274
272275 Can.PInt _ ->
273− pure revDefs
276+ pure revDs
274277
275− Can.PCtor _ _ _ _ _ _ args ->
278+ Can.PCtor _ _ _ _ _ args ->
276279 do name <- Names.generate
277280 foldM
278− (destructCtorArg (Opt.VarLocal name))
279− (Opt.Def name root : revDefs)
281+ (destructCtorArg (Opt.Root name))
282+ (Opt.Destructor name path : revDs)
280283 args
281284
282285
283−destructCons :: Opt.Expr -> Can.Pattern -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]
284−destructCons root hd tl revDefs =
286+destructTwo :: Opt.Path -> Can.Pattern -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]
287+destructTwo path a b revDs =
285288 do name <- Names.generate
286− let list = Opt.VarLocal name
287− destructHelp (Opt.Index list 0) hd =<<
288− destructHelp (Opt.Index list 1) tl (Opt.Def name root : revDefs)
289+ let newRoot = Opt.Root name
290+ destructHelp (Opt.Index Index.first newRoot) a =<<
291+ destructHelp (Opt.Index Index.second newRoot) b (Opt.Destructor name path : revDs)
289292
290293
291−destructCtorArg :: Opt.Expr -> [Opt.Def] -> Can.PatternCtorArg -> Names.Tracker [Opt.Def]
292−destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =
293− destructHelp (Opt.Index root (Index.toZeroBased index)) arg revDefs
294+destructCtorArg :: Opt.Path -> [Opt.Destructor] -> Can.PatternCtorArg -> Names.Tracker [Opt.Destructor]
295+destructCtorArg path revDs (Can.PatternCtorArg index _ arg) =
296+ destructHelp (Opt.Index index path) arg revDs
294297
295298
296299
@@ -301,13 +304,13 @@ optimizePotentialTailCall :: Cycle -> Can.Def -> Names.Tracker Opt.Def
301304optimizePotentialTailCall cycle def =
302305 case def of
303306 Can.Def (A.At _ name) args expr ->
304− do (argNames, defss) <- destructArgs args
305− toTailDef name argNames defss <$>
307+ do (argNames, destructors) <- destructArgs args
308+ toTailDef name argNames destructors <$>
306309 optimizeTail cycle name argNames expr
307310
308311 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
309− do (argNames, defss) <- destructArgs (map fst typedArgs)
310− toTailDef name argNames defss <$>
312+ do (argNames, destructors) <- destructArgs (map fst typedArgs)
313+ toTailDef name argNames destructors <$>
311314 optimizeTail cycle name argNames expr
312315
313316
@@ -355,18 +358,18 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) =
355358 foldM (\bod def -> optimizeDef cycle def bod) obody defs
356359
357360 Can.LetDestruct pattern expr body ->
358− do (dname, defs) <- destruct pattern
361+ do (dname, destructors) <- destruct pattern
359362 oexpr <- optimize cycle expr
360363 obody <- optimizeTail cycle dname argNames body
361364 pure $
362− Opt.Let (Opt.Def dname oexpr) (foldr Opt.Let obody defs)
365+ Opt.Let (Opt.Def dname oexpr) (foldr Opt.Destruct obody destructors)
363366
364367 Can.Case expr branches ->
365368 let
366369 optimizeBranch root (Can.CaseBranch pattern branch) =
367− do defs <- destructHelp (Opt.VarLocal root) pattern []
370+ do destructors <- destructHelp (Opt.Root root) pattern []
368371 obranch <- optimizeTail cycle rootName argNames branch
369− pure (pattern, foldr Opt.Let obranch defs)
372+ pure (pattern, foldr Opt.Destruct obranch destructors)
370373 in
371374 do temp <- Names.generate
372375 oexpr <- optimize cycle expr
@@ -385,12 +388,12 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) =
385388-- DETECT TAIL CALLS
386389
387390
388−toTailDef :: N.Name -> [N.Name] -> [[Opt.Def]] -> Opt.Expr -> Opt.Def
389−toTailDef name argNames defss body =
391+toTailDef :: N.Name -> [N.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def
392+toTailDef name argNames destructors body =
390393 if hasTailCall body then
391− Opt.TailDef name argNames (foldr Opt.Let body (concat defss))
394+ Opt.TailDef name argNames (foldr Opt.Destruct body destructors)
392395 else
393− Opt.Def name (Opt.Function argNames (foldr Opt.Let body (concat defss)))
396+ Opt.Def name (Opt.Function argNames (foldr Opt.Destruct body destructors))
394397
395398
396399hasTailCall :: Opt.Expr -> Bool
src/Optimize/Module.hs+8−9
@@ -9,13 +9,13 @@ module Optimize.Module
99
1010import Prelude hiding (cycle)
1111import Control.Monad (foldM)
12+import qualified Data.List as List
1213import qualified Data.Map as Map
1314import qualified Data.Set as Set
1415
1516import qualified AST.Canonical as Can
1617import qualified AST.Optimized as Opt
1718import qualified AST.Module.Name as ModuleName
18−import qualified Data.Index as Index
1919import qualified Elm.Name as N
2020import qualified Optimize.Expression as Expr
2121import qualified Optimize.Names as Names
@@ -58,14 +58,13 @@ addUnions home unions (Graph fields nodes) =
5858
5959
6060addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
61−addUnion home (Can.Union _ ctors) nodes =
62− Map.union nodes $
63− Map.fromList (Index.indexedMap (ctorToNode home) ctors)
61+addUnion home (Can.Union _ ctors _ _) nodes =
62+ List.foldl' (addCtorNode home) nodes ctors
6463
6564
66−ctorToNode :: ModuleName.Canonical -> Index.ZeroBased -> (N.Name, [t]) -> (Opt.Global, Opt.Node)
67−ctorToNode home index (name, args) =
68− ( Opt.Global home name, Opt.Ctor name index (length args) )
65+addCtorNode :: ModuleName.Canonical -> Nodes -> Can.Ctor -> Nodes
66+addCtorNode home nodes (Can.Ctor name index numArgs _) =
67+ Map.insert (Opt.Global home name) (Opt.Ctor name index numArgs) nodes
6968
7069
7170
@@ -207,10 +206,10 @@ addDefHelp name args body graph =
207206 let
208207 (deps, fields, function) =
209208 Names.run $
210− do (argNames, defss) <- Expr.destructArgs args
209+ do (argNames, destructors) <- Expr.destructArgs args
211210 obody <- Expr.optimize Set.empty body
212211 pure $ Opt.Function argNames $
213− foldr Opt.Let obody (concat defss)
212+ foldr Opt.Destruct obody destructors
214213 in
215214 addToGraph name (Opt.Define function deps) fields graph
216215
src/Optimize/Names.hs+26
@@ -7,6 +7,7 @@ module Optimize.Names
77 , generate
88 , registerKernel
99 , registerGlobal
10+ , registerCtor
1011 , registerField
1112 , registerFieldDict
1213 , registerFieldList
@@ -19,8 +20,10 @@ import qualified Data.Map as Map
1920import qualified Data.Set as Set
2021import qualified Data.Text as Text
2122
23+import qualified AST.Canonical as Can
2224import qualified AST.Optimized as Opt
2325import qualified AST.Module.Name as ModuleName
26+import qualified Data.Index as Index
2427import qualified Elm.Name as N
2528import qualified Elm.Package as Pkg
2629
@@ -70,6 +73,29 @@ registerGlobal home name =
7073 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)
7174
7275
76+registerCtor :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr
77+registerCtor home name index opts =
78+ Tracker $ \uid deps fields ok ->
79+ let
80+ global = Opt.Global home name
81+ newDeps = Set.insert global deps
82+ in
83+ case opts of
84+ Can.Normal ->
85+ ok uid newDeps fields (Opt.VarGlobal global)
86+
87+ Can.Enum ->
88+ ok uid newDeps fields (Opt.VarEnum global index)
89+
90+ Can.Unbox ->
91+ ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)
92+
93+
94+identity :: Opt.Global
95+identity =
96+ Opt.Global ModuleName.basics N.identity
97+
98+
7399registerField :: N.Name -> a -> Tracker a
74100registerField name value =
75101 Tracker $ \uid d fields ok ->
src/Optimize/Port.hs+22−20
@@ -18,7 +18,6 @@ import qualified AST.Module.Name as ModuleName
1818import qualified AST.Utils.Type as Type
1919import qualified Data.Index as Index
2020import qualified Elm.Name as N
21−import qualified Optimize.DecisionTree as DT
2221import qualified Optimize.Names as Names
2322
2423
@@ -85,13 +84,9 @@ encodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
8584encodeMaybe tipe =
8685 do null <- encode "null"
8786 encoder <- toEncoder tipe
88−
89− let test = (DT.Empty, DT.IsCtor 2 "Just" Index.first)
90− let just = Opt.Call encoder [ Opt.Index (Opt.VarLocal N.dollar) 0 ]
91− let leaf expr = Opt.Leaf (Opt.Inline expr)
92−
87+ destruct <- Names.registerGlobal ModuleName.maybe "destruct"
9388 return $ Opt.Function [N.dollar] $
94− Opt.Case N.dollar N.dollar (Opt.Chain [test] (leaf just) (leaf null)) []
89+ Opt.Call destruct [ null, encoder, Opt.VarLocal N.dollar ]
9590
9691
9792encodeList :: Can.Type -> Names.Tracker Opt.Expr
@@ -117,21 +112,28 @@ encodeArray tipe =
117112encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
118113encodeTuple a b maybeC =
119114 let
120− convert index tipe =
115+ let_ arg index body =
116+ Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root N.dollar))) body
117+
118+ encodeArg arg tipe =
121119 do encoder <- toEncoder tipe
122− return $ Opt.Call encoder [ Opt.Index (Opt.VarLocal N.dollar) index ]
120+ return $ Opt.Call encoder [ Opt.VarLocal arg ]
123121 in
124− Opt.Function [N.dollar] <$> (
125− Opt.Call
126− <$> encode "list"
127− <*>
128− case maybeC of
129− Nothing ->
130− sequence [ convert 0 a, convert 1 b ]
131−
132− Just c ->
133− sequence [ convert 0 a, convert 1 b, convert 2 c ]
134− )
122+ do list <- encode "list"
123+ arg1 <- encodeArg "a" a
124+ arg2 <- encodeArg "b" b
125+
126+ Opt.Function [N.dollar] <$>
127+ let_ "a" Index.first <$>
128+ let_ "b" Index.second <$>
129+ case maybeC of
130+ Nothing ->
131+ return $ Opt.Call list [ arg1, arg2 ]
132+
133+ Just c ->
134+ do arg3 <- encodeArg "c" c
135+ return $ let_ "c" Index.third $
136+ Opt.Call list [ arg1, arg2, arg3 ]
135137
136138
137139