8e73b5b · elk · git.iko.soy

git.iko.soy/elk

Create Optimize.Module for creating object graphs

The graph nodes are set up for cyclic values, tail calls, and effect managers. This also tracks record field name frequency, so we can assign shorter names with a reasonable heuristic.

commit8e73b5bc281e87e3c154bd081d1328fd69fbabc4 authorEvan Czaplicki <evancz@users.noreply.github.com> dateSat 2 Dec 2017, 11:50 (9 years ago) parent966edcd

6 files changed+474−126

compare with master

unifiedsplit

src/AST/Optimized.hs+54−38 src/Elm/Name.hs+13 src/Optimize.hs → src/Optimize/Expression.hs+75−72 src/Optimize/Module.hs+306 src/Optimize/Names.hs+15−3 src/Optimize/Port.hs+11−13

src/AST/Optimized.hs+54−38

@@ -7,6 +7,7 @@ module AST.Optimized

77 , Choice(..)

88 , Graph(..)

99 , Node(..)

10+ , EffectsType(..)

1011 )

1112 where

1213

@@ -14,6 +15,7 @@ module AST.Optimized

1415import Control.Monad (liftM, liftM2, liftM3, liftM4)

1516import Data.Binary

1617import qualified Data.Map as Map

18+import qualified Data.Set as Set

1719import Data.Text (Text)

1820

1921import qualified AST.Module.Name as ModuleName

@@ -34,6 +36,7 @@ data Expr

3436 | Float Double

3537 | VarLocal N.Name

3638 | VarGlobal Global

39+ | VarCycle ModuleName.Canonical N.Name

3740 | VarDebug N.Name ModuleName.Canonical R.Region (Maybe Expr)

3841 | VarKernel N.Name N.Name

3942 | List [Expr]

@@ -97,11 +100,22 @@ data Choice

97100

98101data Graph =

99102 Graph

100− { _nodes :: Map.Map Global Node

103+ { _fields :: Map.Map N.Name Int

104+ , _nodes :: Map.Map Global Node

101105 }

102106

103107

104−data Node = Node

108+data Node

109+ = Define Expr (Set.Set N.Name) (Set.Set Global)

110+ | DefineTailFunc [N.Name] Expr (Set.Set N.Name) (Set.Set Global)

111+ | Link Global

112+ | Cycle [(N.Name, Expr)] (Set.Set N.Name) (Set.Set Global)

113+ | PortIncoming Expr (Set.Set N.Name) (Set.Set Global)

114+ | PortOutgoing Expr (Set.Set N.Name) (Set.Set Global)

115+ | Manager EffectsType

116+

117+

118+data EffectsType = Cmd | Sub | Fx

105119

106120

107121

@@ -122,24 +136,25 @@ instance Binary Expr where

122136 Float a -> putWord8 3 >> put a

123137 VarLocal a -> putWord8 4 >> put a

124138 VarGlobal a -> putWord8 5 >> put a

125− VarDebug a b c d -> putWord8 6 >> put a >> put b >> put c >> put d

126− VarKernel a b -> putWord8 7 >> put a >> put b

127− List a -> putWord8 8 >> put a

128− Function a b -> putWord8 9 >> put a >> put b

129− Call a b -> putWord8 10 >> put a >> put b

130− TailCall a b c -> putWord8 11 >> put a >> put b >> put c

131− If a b -> putWord8 12 >> put a >> put b

132− Let a b -> putWord8 13 >> put a >> put b

133− Case a b c -> putWord8 14 >> put a >> put b >> put c

134− Ctor a b -> putWord8 15 >> put a >> put b

135− CtorAccess a b -> putWord8 16 >> put a >> put b

136− Accessor a -> putWord8 17 >> put a

137− Access a b -> putWord8 18 >> put a >> put b

138− Update a b -> putWord8 19 >> put a >> put b

139− Record a -> putWord8 20 >> put a

140− Unit -> putWord8 21

141− Tuple a b c -> putWord8 22 >> put a >> put b >> put c

142− Shader a -> putWord8 23 >> put a

139+ VarCycle a b -> putWord8 6 >> put a >> put b

140+ VarDebug a b c d -> putWord8 7 >> put a >> put b >> put c >> put d

141+ VarKernel a b -> putWord8 8 >> put a >> put b

142+ List a -> putWord8 9 >> put a

143+ Function a b -> putWord8 10 >> put a >> put b

144+ Call a b -> putWord8 11 >> put a >> put b

145+ TailCall a b c -> putWord8 12 >> put a >> put b >> put c

146+ If a b -> putWord8 13 >> put a >> put b

147+ Let a b -> putWord8 14 >> put a >> put b

148+ Case a b c -> putWord8 15 >> put a >> put b >> put c

149+ Ctor a b -> putWord8 16 >> put a >> put b

150+ CtorAccess a b -> putWord8 17 >> put a >> put b

151+ Accessor a -> putWord8 18 >> put a

152+ Access a b -> putWord8 19 >> put a >> put b

153+ Update a b -> putWord8 20 >> put a >> put b

154+ Record a -> putWord8 21 >> put a

155+ Unit -> putWord8 22

156+ Tuple a b c -> putWord8 23 >> put a >> put b >> put c

157+ Shader a -> putWord8 24 >> put a

143158

144159 get =

145160 do word <- getWord8

@@ -150,24 +165,25 @@ instance Binary Expr where

150165 3 -> liftM Float get

151166 4 -> liftM VarLocal get

152167 5 -> liftM VarGlobal get

153− 6 -> liftM4 VarDebug get get get get

154− 7 -> liftM2 VarKernel get get

155− 8 -> liftM List get

156− 9 -> liftM2 Function get get

157− 10 -> liftM2 Call get get

158− 11 -> liftM3 TailCall get get get

159− 12 -> liftM2 If get get

160− 13 -> liftM2 Let get get

161− 14 -> liftM3 Case get get get

162− 15 -> liftM2 Ctor get get

163− 16 -> liftM2 CtorAccess get get

164− 17 -> liftM Accessor get

165− 18 -> liftM2 Access get get

166− 19 -> liftM2 Update get get

167− 20 -> liftM Record get

168− 21 -> pure Unit

169− 22 -> liftM3 Tuple get get get

170− 23 -> liftM Shader get

168+ 6 -> liftM2 VarCycle get get

169+ 7 -> liftM4 VarDebug get get get get

170+ 8 -> liftM2 VarKernel get get

171+ 9 -> liftM List get

172+ 10 -> liftM2 Function get get

173+ 11 -> liftM2 Call get get

174+ 12 -> liftM3 TailCall get get get

175+ 13 -> liftM2 If get get

176+ 14 -> liftM2 Let get get

177+ 15 -> liftM3 Case get get get

178+ 16 -> liftM2 Ctor get get

179+ 17 -> liftM2 CtorAccess get get

180+ 18 -> liftM Accessor get

181+ 19 -> liftM2 Access get get

182+ 20 -> liftM2 Update get get

183+ 21 -> liftM Record get

184+ 22 -> pure Unit

185+ 23 -> liftM3 Tuple get get get

186+ 24 -> liftM Shader get

171187 _ -> error "problem getting Opt.Expr binary"

172188

173189

src/Elm/Name.hs+13

@@ -3,6 +3,8 @@

33module Elm.Name

44 ( Name

55 , toString

6+ , localFromInt

7+ , toCompositeName

68 , int, float, bool, char, string

79 , maybe, list, array

810 , task, router, cmd, sub

@@ -12,6 +14,7 @@ module Elm.Name

1214

1315

1416import Prelude hiding (maybe, negate)

17+import qualified Data.Set as Set

1518import qualified Data.Text as Text

1619

1720

@@ -27,6 +30,16 @@ toString =

2730 Text.unpack

2831

2932

33+localFromInt :: Int -> Name

34+localFromInt n =

35+ Text.pack ('x' : show n)

36+

37+

38+toCompositeName :: Set.Set Name -> Name

39+toCompositeName names =

40+ Text.cons '$' (Text.intercalate "$" (Set.toList names))

41+

42+

3043

3144-- COMMON NAMES

3245

src/Optimize.hs → src/Optimize/Expression.hsrenamed+75−72

@@ -1,12 +1,17 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

3−module Optimize

4− ( optimizeExpr

3+module Optimize.Expression

4+ ( Cycle

5+ , optimize

6+ , destructArgs

7+ , optimizePotentialTailCall

58 )

69 where

710

811

12+import Prelude hiding (cycle)

913import Control.Monad (foldM)

14+import qualified Data.Set as Set

1015

1116import qualified AST.Canonical as Can

1217import qualified AST.Optimized as Opt

@@ -22,18 +27,21 @@ import qualified Reporting.Annotation as A

2227-- OPTIMIZE

2328

2429

30+type Cycle =

31+ Set.Set N.Name

2532

26−-- EXPRESSIONS

2733

28−

29−optimizeExpr :: Can.Expr -> Names.Tracker Opt.Expr

30−optimizeExpr (A.At region expression) =

34+optimize :: Cycle -> Can.Expr -> Names.Tracker Opt.Expr

35+optimize cycle (A.At region expression) =

3136 case expression of

3237 Can.VarLocal name ->

3338 pure (Opt.VarLocal name)

3439

3540 Can.VarTopLevel home name ->

36− Names.registerGlobal home name

41+ if Set.member name cycle then

42+ pure (Opt.VarCycle home name)

43+ else

44+ Names.registerGlobal home name

3745

3846 Can.VarKernel home name ->

3947 Names.registerKernel home (Opt.VarKernel home name)

@@ -60,58 +68,58 @@ optimizeExpr (A.At region expression) =

6068 pure (Opt.Float float)

6169

6270 Can.List entries ->

63− Opt.List <$> traverse optimizeExpr entries

71+ Opt.List <$> traverse (optimize cycle) entries

6472

6573 Can.Negate expr ->

6674 do func <- Names.registerGlobal ModuleName.basics N.negate

67− arg <- optimizeExpr expr

75+ arg <- optimize cycle expr

6876 pure $ Opt.Call func [arg]

6977

7078 Can.Binop _ home name _ left right ->

7179 do optFunc <- Names.registerGlobal home name

72− optLeft <- optimizeExpr left

73− optRight <- optimizeExpr right

80+ optLeft <- optimize cycle left

81+ optRight <- optimize cycle right

7482 return (Opt.Call optFunc [optLeft, optRight])

7583

7684 Can.Lambda args body ->

7785 do (argNames, defss) <- destructArgs args

78− obody <- optimizeExpr body

86+ obody <- optimize cycle body

7987 pure $ Opt.Function argNames (foldr Opt.Let obody (concat defss))

8088

8189 Can.Call func args ->

8290 Opt.Call

83− <$> optimizeExpr func

84− <*> traverse optimizeExpr args

91+ <$> optimize cycle func

92+ <*> traverse (optimize cycle) args

8593

8694 Can.If branches finally ->

8795 let

8896 optimizeBranch (condition, branch) =

8997 (,)

90− <$> optimizeExpr condition

91− <*> optimizeExpr branch

98+ <$> optimize cycle condition

99+ <*> optimize cycle branch

92100 in

93101 Opt.If

94102 <$> traverse optimizeBranch branches

95− <*> optimizeExpr finally

103+ <*> optimize cycle finally

96104

97105 Can.Let def body ->

98− optimizeDef def =<< optimizeExpr body

106+ optimizeDef cycle def =<< optimize cycle body

99107

100108 Can.LetRec defs body ->

101109 case defs of

102110 [def] ->

103111 Opt.Let

104− <$> optimizePotentialTailCall def

105− <*> optimizeExpr body

112+ <$> optimizePotentialTailCall cycle def

113+ <*> optimize cycle body

106114

107115 _ ->

108− do obody <- optimizeExpr body

109− foldM (\bod def -> optimizeDef def bod) obody defs

116+ do obody <- optimize cycle body

117+ foldM (\bod def -> optimizeDef cycle def bod) obody defs

110118

111119 Can.LetDestruct pattern expr body ->

112120 do (name, defs) <- destruct pattern

113− oexpr <- optimizeExpr expr

114− obody <- optimizeExpr body

121+ oexpr <- optimize cycle expr

122+ obody <- optimize cycle body

115123 pure $

116124 Opt.Let (Opt.Def name oexpr) (foldr Opt.Let obody defs)

117125

@@ -119,10 +127,10 @@ optimizeExpr (A.At region expression) =

119127 let

120128 optimizeBranch root (Can.CaseBranch pattern branch) =

121129 do defs <- destructHelp (Opt.VarLocal root) pattern []

122− obranch <- optimizeExpr branch

130+ obranch <- optimize cycle branch

123131 pure (pattern, foldr Opt.Let obranch defs)

124132 in

125− do oexpr <- optimizeExpr expr

133+ do oexpr <- optimize cycle expr

126134 case oexpr of

127135 Opt.VarLocal root ->

128136 Case.optimize root <$> traverse (optimizeBranch root) branches

@@ -135,26 +143,26 @@ optimizeExpr (A.At region expression) =

135143 Names.registerField field (Opt.Accessor field)

136144

137145 Can.Access record field ->

138− do optRecord <- optimizeExpr record

146+ do optRecord <- optimize cycle record

139147 Names.registerField field (Opt.Access optRecord field)

140148

141149 Can.Update record updates ->

142− Names.registerFields updates Opt.Update

143− <*> optimizeExpr record

144− <*> traverse optimizeExpr updates

150+ Names.registerFieldDict updates Opt.Update

151+ <*> optimize cycle record

152+ <*> traverse (optimize cycle) updates

145153

146154 Can.Record fields ->

147− Names.registerFields fields Opt.Record

148− <*> traverse optimizeExpr fields

155+ Names.registerFieldDict fields Opt.Record

156+ <*> traverse (optimize cycle) fields

149157

150158 Can.Unit ->

151159 Names.registerKernel N.utils Opt.Unit

152160

153161 Can.Tuple a b maybeC ->

154162 Names.registerKernel N.utils Opt.Tuple

155− <*> optimizeExpr a

156− <*> optimizeExpr b

157− <*> traverse optimizeExpr maybeC

163+ <*> optimize cycle a

164+ <*> optimize cycle b

165+ <*> traverse (optimize cycle) maybeC

158166

159167 Can.Shader _ src _ ->

160168 pure (Opt.Shader src)

@@ -164,28 +172,27 @@ optimizeExpr (A.At region expression) =

164172-- DEFINITION

165173

166174

167−optimizeDef :: Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr

168−optimizeDef def body =

175+optimizeDef :: Cycle -> Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr

176+optimizeDef cycle def body =

169177 case def of

170178 Can.Def (A.At _ name) args expr ->

171− optimizeDefHelp name args expr body

179+ optimizeDefHelp cycle name args expr body

172180

173181 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->

174− optimizeDefHelp name (map fst typedArgs) expr body

182+ optimizeDefHelp cycle name (map fst typedArgs) expr body

175183

176184

177−optimizeDefHelp :: N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr

178−optimizeDefHelp name args expr body =

185+optimizeDefHelp :: Cycle -> N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr

186+optimizeDefHelp cycle name args expr body =

179187 case args of

180188 [] ->

181− do oexpr <- optimizeExpr expr

189+ do oexpr <- optimize cycle expr

182190 pure $ Opt.Let (Opt.Def name oexpr) body

183191

184192 _ ->

185193 do (argNames, defss) <- destructArgs args

186− let func = Opt.Function argNames (foldr Opt.Let body (concat defss))

187− pure $

188− Opt.Let (Opt.Def name func) body

194+ let oexpr = Opt.Function argNames (foldr Opt.Let body (concat defss))

195+ pure $ Opt.Let (Opt.Def name oexpr) body

189196

190197

191198

@@ -223,12 +230,8 @@ destructHelp root (A.At region pattern) revDefs =

223230 pure (Opt.Def name root : revDefs)

224231

225232 Can.PRecord fields ->

226− let

227− addFieldDef defs name =

228− Names.registerField name $

229− Opt.Def name (Opt.Access root name) : defs

230− in

231− foldM addFieldDef revDefs fields

233+ let toDef name = Opt.Def name (Opt.Access root name) in

234+ Names.registerFieldList fields (map toDef fields ++ revDefs)

232235

233236 Can.PAlias subPattern name ->

234237 destructHelp (Opt.VarLocal name) subPattern $

@@ -294,58 +297,58 @@ destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =

294297-- TAIL CALL

295298

296299

297−optimizePotentialTailCall :: Can.Def -> Names.Tracker Opt.Def

298−optimizePotentialTailCall def =

300+optimizePotentialTailCall :: Cycle -> Can.Def -> Names.Tracker Opt.Def

301+optimizePotentialTailCall cycle def =

299302 case def of

300303 Can.Def (A.At _ name) args expr ->

301304 do (argNames, defss) <- destructArgs args

302305 toTailDef name argNames defss <$>

303− optimizeTailExpr name argNames expr

306+ optimizeTail cycle name argNames expr

304307

305308 Can.TypedDef (A.At _ name) _ typedArgs expr _ ->

306309 do (argNames, defss) <- destructArgs (map fst typedArgs)

307310 toTailDef name argNames defss <$>

308− optimizeTailExpr name argNames expr

311+ optimizeTail cycle name argNames expr

309312

310313

311−optimizeTailExpr :: N.Name -> [N.Name] -> Can.Expr -> Names.Tracker Opt.Expr

312−optimizeTailExpr name argNames locExpr@(A.At _ expression) =

314+optimizeTail :: Cycle -> N.Name -> [N.Name] -> Can.Expr -> Names.Tracker Opt.Expr

315+optimizeTail cycle name argNames locExpr@(A.At _ expression) =

313316 case expression of

314317 Can.Call (A.At _ (Can.VarTopLevel _ funcName)) args ->

315318 if funcName == name && length args == length argNames then

316− Opt.TailCall name argNames <$> traverse optimizeExpr args

319+ Opt.TailCall name argNames <$> traverse (optimize cycle) args

317320 else

318− optimizeExpr locExpr

321+ optimize cycle locExpr

319322

320323 Can.If branches finally ->

321324 let

322325 optimizeBranch (condition, branch) =

323326 (,)

324− <$> optimizeExpr condition

325− <*> optimizeTailExpr name argNames branch

327+ <$> optimize cycle condition

328+ <*> optimizeTail cycle name argNames branch

326329 in

327330 Opt.If

328331 <$> traverse optimizeBranch branches

329− <*> optimizeTailExpr name argNames finally

332+ <*> optimizeTail cycle name argNames finally

330333

331334 Can.Let def body ->

332− optimizeDef def =<< optimizeTailExpr name argNames body

335+ optimizeDef cycle def =<< optimizeTail cycle name argNames body

333336

334337 Can.LetRec defs body ->

335338 case defs of

336339 [def] ->

337340 Opt.Let

338− <$> optimizePotentialTailCall def

339− <*> optimizeTailExpr name argNames body

341+ <$> optimizePotentialTailCall cycle def

342+ <*> optimizeTail cycle name argNames body

340343

341344 _ ->

342− do obody <- optimizeTailExpr name argNames body

343− foldM (\bod def -> optimizeDef def bod) obody defs

345+ do obody <- optimizeTail cycle name argNames body

346+ foldM (\bod def -> optimizeDef cycle def bod) obody defs

344347

345348 Can.LetDestruct pattern expr body ->

346349 do (dname, defs) <- destruct pattern

347− oexpr <- optimizeExpr expr

348− obody <- optimizeTailExpr dname argNames body

350+ oexpr <- optimize cycle expr

351+ obody <- optimizeTail cycle dname argNames body

349352 pure $

350353 Opt.Let (Opt.Def dname oexpr) (foldr Opt.Let obody defs)

351354

@@ -353,10 +356,10 @@ optimizeTailExpr name argNames locExpr@(A.At _ expression) =

353356 let

354357 optimizeBranch root (Can.CaseBranch pattern branch) =

355358 do defs <- destructHelp (Opt.VarLocal root) pattern []

356− obranch <- optimizeTailExpr name argNames branch

359+ obranch <- optimizeTail cycle name argNames branch

357360 pure (pattern, foldr Opt.Let obranch defs)

358361 in

359− do oexpr <- optimizeExpr expr

362+ do oexpr <- optimize cycle expr

360363 case oexpr of

361364 Opt.VarLocal root ->

362365 Case.optimize root <$> traverse (optimizeBranch root) branches

@@ -366,7 +369,7 @@ optimizeTailExpr name argNames locExpr@(A.At _ expression) =

366369 Case.optimize root <$> traverse (optimizeBranch root) branches

367370

368371 _ ->

369− optimizeExpr locExpr

372+ optimize cycle locExpr

370373

371374

372375

src/Optimize/Module.hsnew file+306

@@ -0,0 +1,306 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Optimize.Module

4+ ( optimize

5+ )

6+ where

9+import Prelude hiding (cycle)

10+import Control.Monad (foldM)

11+import qualified Data.Map as Map

12+import qualified Data.Set as Set

13+

14+import qualified AST.Canonical as Can

15+import qualified AST.Optimized as Opt

16+import qualified AST.Module.Name as ModuleName

17+import qualified Elm.Name as N

18+import qualified Optimize.Expression as Expr

19+import qualified Optimize.Names as Names

20+import qualified Optimize.Port as Port

21+import qualified Reporting.Annotation as A

22+

23+

24+

25+-- OPTIMIZE

26+

27+

28+optimize :: Can.Module -> Opt.Graph

29+optimize (Can.Module home _ _ decls unions aliases _ effects) =

30+ addEffects home effects $

31+ addUnions home unions $

32+ addAliases home aliases $

33+ addDecls home decls $

34+ Opt.Graph Map.empty Map.empty

35+

36+

37+

38+-- UNION

39+

40+

41+addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Opt.Graph -> Opt.Graph

42+addUnions home unions (Opt.Graph fields nodes) =

43+ Opt.Graph fields $

44+ Map.foldr (addUnion home) nodes unions

45+

46+

47+type Nodes =

48+ Map.Map Opt.Global Opt.Node

49+

50+

51+addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes

52+addUnion home (Can.Union _ ctors) nodes =

53+ foldr (addCtor home) nodes ctors

54+

55+

56+addCtor :: ModuleName.Canonical -> (N.Name, [t]) -> Nodes -> Nodes

57+addCtor home (ctor, args) nodes =

58+ let

59+ argNames =

60+ map N.localFromInt [ 1 .. length args ]

61+

62+ function =

63+ Opt.Function argNames $

64+ Opt.Ctor ctor (map Opt.VarLocal argNames)

65+

66+ node =

67+ Opt.Define function Set.empty Set.empty

68+ in

69+ Map.insert (Opt.Global home ctor) node nodes

70+

71+

72+

73+-- ALIAS

74+

75+

76+addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Opt.Graph -> Opt.Graph

77+addAliases home aliases graph =

78+ Map.foldrWithKey (addAlias home) graph aliases

79+

80+

81+addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph

82+addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph fieldCounts nodes) =

83+ case maybeFields of

84+ Nothing ->

85+ graph

86+

87+ Just fields ->

88+ let

89+ function =

90+ Opt.Function fields $ Opt.Record $

91+ Map.fromList $ map toPair fields

92+

93+ node =

94+ Opt.Define function Set.empty Set.empty

95+ in

96+ Opt.Graph

97+ (foldr addOne fieldCounts fields)

98+ (Map.insert (Opt.Global home name) node nodes)

99+

100+

101+toPair :: N.Name -> (N.Name, Opt.Expr)

102+toPair field =

103+ ( field, Opt.VarLocal field )

104+

105+

106+addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int

107+addOne name fields =

108+ Map.insertWith (+) name 1 fields

109+

110+

111+

112+-- ADD EFFECTS

113+

114+

115+addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph

116+addEffects home effects graph@(Opt.Graph fields nodes) =

117+ case effects of

118+ Can.NoEffects ->

119+ graph

120+

121+ Can.Ports ports ->

122+ Map.foldrWithKey (addPort home) graph ports

123+

124+ Can.Manager _ _ _ manager ->

125+ Opt.Graph fields $

126+ let

127+ fx = Opt.Global home "$fx$"

128+ cmd = Opt.Global home "command"

129+ sub = Opt.Global home "subscription"

130+ link = Opt.Link fx

131+ in

132+ case manager of

133+ Can.Cmd _ ->

134+ Map.insert cmd link $

135+ Map.insert fx (Opt.Manager Opt.Cmd) nodes

136+

137+ Can.Sub _ ->

138+ Map.insert sub link $

139+ Map.insert fx (Opt.Manager Opt.Sub) nodes

140+

141+ Can.Fx _ _ ->

142+ Map.insert cmd link $

143+ Map.insert sub link $

144+ Map.insert fx (Opt.Manager Opt.Fx) nodes

145+

146+

147+

148+addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph

149+addPort home name port_ graph =

150+ case port_ of

151+ Can.Incoming _ tipe ->

152+ let

153+ (kernels, globals, fields, decoder) = Names.run (Port.toDecoder tipe)

154+ node = Opt.PortIncoming decoder kernels globals

155+ in

156+ addToGraph (Opt.Global home name) node fields graph

157+

158+ Can.Outgoing _ tipe ->

159+ let

160+ (kernels, globals, fields, encoder) = Names.run (Port.toEncoder tipe)

161+ node = Opt.PortOutgoing encoder kernels globals

162+ in

163+ addToGraph (Opt.Global home name) node fields graph

164+

165+

166+

167+-- ADD DECLS

168+

169+

170+addDecls :: ModuleName.Canonical -> Can.Decls -> Opt.Graph -> Opt.Graph

171+addDecls home decls graph =

172+ case decls of

173+ Can.Declare def subDecls ->

174+ addDecls home subDecls (addDef home def graph)

175+

176+ Can.DeclareRec defs subDecls ->

177+ addDecls home subDecls (addRecDefs home defs graph)

178+

179+ Can.SaveTheEnvironment ->

180+ graph

181+

182+

183+

184+-- ADD DEFS

185+

186+

187+addDef :: ModuleName.Canonical -> Can.Def -> Opt.Graph -> Opt.Graph

188+addDef home def graph =

189+ case def of

190+ Can.Def (A.At _ name) args body ->

191+ addDefHelp (Opt.Global home name) args body graph

192+

193+ Can.TypedDef (A.At _ name) _ typedArgs body _ ->

194+ addDefHelp (Opt.Global home name) (map fst typedArgs) body graph

195+

196+

197+addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Opt.Graph

198+addDefHelp name args body graph =

199+ case args of

200+ [] ->

201+ let

202+ (kernels, globals, fields, value) =

203+ Names.run (Expr.optimize Set.empty body)

204+ in

205+ addToGraph name (Opt.Define value kernels globals) fields graph

206+

207+ _ ->

208+ let

209+ (kernels, globals, fields, function) =

210+ Names.run $

211+ do (argNames, defss) <- Expr.destructArgs args

212+ obody <- Expr.optimize Set.empty body

213+ pure $ Opt.Function argNames $

214+ foldr Opt.Let obody (concat defss)

215+ in

216+ addToGraph name (Opt.Define function kernels globals) fields graph

217+

218+

219+addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph

220+addToGraph name node fields (Opt.Graph fieldCounts nodes) =

221+ Opt.Graph

222+ (Map.unionWith (+) fields fieldCounts)

223+ (Map.insert name node nodes)

224+

225+

226+

227+-- ADD RECURSIVE DEFS

228+

229+

230+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph

231+addRecDefs home defs graph =

232+ let

233+ cycleValues =

234+ foldr addValueName Set.empty defs

235+

236+ dummyName =

237+ Opt.Global home (N.toCompositeName cycleValues)

238+

239+ (kernels, globals, fields, State cyclicValuePairs newGraph) =

240+ Names.run $

241+ foldM (addRecDef home dummyName cycleValues) (State [] graph) defs

242+

243+ node =

244+ Opt.Cycle cyclicValuePairs kernels globals

245+ in

246+ addToGraph dummyName node fields newGraph

247+

248+

249+addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name

250+addValueName def valueNames =

251+ case def of

252+ Can.Def (A.At _ name) [] _ ->

253+ Set.insert name valueNames

254+

255+ Can.TypedDef (A.At _ name) _ [] _ _ ->

256+ Set.insert name valueNames

257+

258+ _ ->

259+ valueNames

260+

261+

262+

263+-- ADD RECURSIVE DEFS

264+

265+

266+data State =

267+ State

268+ { _values :: [(N.Name, Opt.Expr)]

269+ , _graph :: Opt.Graph

270+ }

271+

272+

273+addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State

274+addRecDef home dummyName cycle state@(State values graph) def =

275+ case def of

276+ Can.Def (A.At _ name) [] body ->

277+ addRecValue home dummyName cycle name body state

278+

279+ Can.TypedDef (A.At _ name) _ [] body _ ->

280+ addRecValue home dummyName cycle name body state

281+

282+ _ ->

283+ let

284+ (kernels, globals, fields, odef) =

285+ Names.run (Expr.optimizePotentialTailCall Set.empty def)

286+ in

287+ pure $ State values $

288+ case odef of

289+ Opt.Def name body ->

290+ let node = Opt.Define body kernels globals in

291+ addToGraph (Opt.Global home name) node fields graph

292+

293+ Opt.TailDef name args body ->

294+ let node = Opt.DefineTailFunc args body kernels globals in

295+ addToGraph (Opt.Global home name) node fields graph

296+

297+

298+addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State

299+addRecValue home dummyName cycle name body (State values (Opt.Graph fields nodes)) =

300+ do obody <- Expr.optimize cycle body

301+ pure $

302+ State

303+ { _values = (name, obody) : values

304+ , _graph = Opt.Graph fields $

305+ Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes

306+ }

src/Optimize/Names.hs+15−3

@@ -7,8 +7,9 @@ module Optimize.Names

77 , generate

88 , registerKernel

99 , registerGlobal

10− , registerFields

1110 , registerField

11+ , registerFieldDict

12+ , registerFieldList

1213 )

1314 where

1415

@@ -70,8 +71,8 @@ registerField name value =

7071 ok n k g (Map.insertWith (+) name 1 fields) value

7172

7273

73−registerFields :: Map.Map N.Name v -> a -> Tracker a

74−registerFields newFields value =

74+registerFieldDict :: Map.Map N.Name v -> a -> Tracker a

75+registerFieldDict newFields value =

7576 Tracker $ \n k g fields ok ->

7677 ok n k g (Map.unionWith (+) fields (Map.map toOne newFields)) value

7778

@@ -80,6 +81,17 @@ toOne :: a -> Int

8081toOne _ = 1

8182

8283

84+registerFieldList :: [N.Name] -> a -> Tracker a

85+registerFieldList names value =

86+ Tracker $ \n k g fields ok ->

87+ ok n k g (foldr addOne fields names) value

88+

89+

90+addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int

91+addOne name fields =

92+ Map.insertWith (+) name 1 fields

93+

94+

8395

8496-- INSTANCES

8597

src/Optimize/Port.hs+11−13

@@ -11,7 +11,6 @@ module Optimize.Port

1111import Prelude hiding (maybe, null)

1212import Control.Monad (foldM)

1313import qualified Data.Map as Map

14−import qualified Data.Text as Text

1514

1615import qualified AST.Canonical as Can

1716import qualified AST.Optimized as Opt

@@ -67,12 +66,15 @@ toEncoder tipe =

6766

6867 Can.TRecord fields Nothing ->

6968 let

70− encodeField field fieldType =

69+ encodeField (name, fieldType) =

7170 do encoder <- toEncoder fieldType

72− return $ Opt.Call encoder [Opt.Access (Opt.VarLocal "r") field]

71+ let value = Opt.Call encoder [Opt.Access (Opt.VarLocal "r") name]

72+ return $ Opt.Tuple (Opt.Str name) value Nothing

7373 in

74− do record <- Map.traverseWithKey encodeField fields

75− return $ Opt.Function ["r"] (Opt.Record record)

74+ do object <- encode "object"

75+ keyValuePairs <- traverse encodeField (Map.toList fields)

76+ Names.registerFieldDict fields $

77+ Opt.Function ["r"] (Opt.Call object [Opt.List keyValuePairs])

7678

7779

7880

@@ -266,12 +268,7 @@ decodeTuple a b maybeC =

266268

267269toLocal :: Int -> Opt.Expr

268270toLocal index =

269− Opt.VarLocal (indexToName index)

270−

271−

272−indexToName :: Int -> N.Name

273−indexToName index =

274− Text.pack ('x' : show index)

271+ Opt.VarLocal (N.localFromInt index)

275272

276273

277274indexAndThen :: Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr

@@ -281,7 +278,7 @@ indexAndThen i tipe decoder =

281278 typeDecoder <- toDecoder tipe

282279 return $

283280 Opt.Call andThen

284− [ Opt.Function [indexToName i] decoder

281+ [ Opt.Function [N.localFromInt i] decoder

285282 , Opt.Call index [ Opt.Int i, typeDecoder ]

286283 ]

287284

@@ -300,7 +297,8 @@ decodeRecord fields =

300297 Opt.Record (Map.mapWithKey toFieldExpr fields)

301298 in

302299 do succeed <- decode "succeed"

303− foldM fieldAndThen (Opt.Call succeed [record]) (Map.toList fields)

300+ foldM fieldAndThen (Opt.Call succeed [record]) =<<

301+ Names.registerFieldDict fields (Map.toList fields)

304302

305303

306304fieldAndThen :: Opt.Expr -> (N.Name, Can.Type) -> Names.Tracker Opt.Expr