8e73b5b · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Create Optimize.Module for creating object graphs

8e73b5bEvan Czaplicki9 years ago

src/AST/Optimized.hs+54−38

compare with master

unifiedsplit

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

7 , Choice(..)

8 , Graph(..)

9 , Node(..)

10+ , EffectsType(..)

10 )

11 )

11 where

12 where

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

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

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

15import Data.Binary

16import Data.Binary

16import qualified Data.Map as Map

17import qualified Data.Map as Map

18+import qualified Data.Set as Set

17import Data.Text (Text)

19import Data.Text (Text)

19import qualified AST.Module.Name as ModuleName

21import qualified AST.Module.Name as ModuleName

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

34 | Float Double

36 | Float Double

35 | VarLocal N.Name

37 | VarLocal N.Name

36 | VarGlobal Global

38 | VarGlobal Global

39+ | VarCycle ModuleName.Canonical N.Name

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

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

38 | VarKernel N.Name N.Name

41 | VarKernel N.Name N.Name

39 | List [Expr]

42 | List [Expr]

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

100

98data Graph =

101data Graph =

99 Graph

102 Graph

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

100− { _nodes :: Map.Map Global Node

104+ , _nodes :: Map.Map Global Node

101 }

105 }

102

106

103

107

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

105

119

106

120

107

121

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

122 Float a -> putWord8 3 >> put a

136 Float a -> putWord8 3 >> put a

123 VarLocal a -> putWord8 4 >> put a

137 VarLocal a -> putWord8 4 >> put a

124 VarGlobal a -> putWord8 5 >> put a

138 VarGlobal a -> putWord8 5 >> put a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

147+ Let a b -> putWord8 14 >> 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

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

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

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

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

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

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

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

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

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

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

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

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

140− Unit -> putWord8 21

155+ Unit -> putWord8 22

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

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

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

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

143

158

144 get =

159 get =

145 do word <- getWord8

160 do word <- getWord8

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

150 3 -> liftM Float get

165 3 -> liftM Float get

151 4 -> liftM VarLocal get

166 4 -> liftM VarLocal get

152 5 -> liftM VarGlobal get

167 5 -> liftM VarGlobal get

168+ 6 -> liftM2 VarCycle get get

153− 6 -> liftM4 VarDebug get get get get

169+ 7 -> liftM4 VarDebug get get get get

154− 7 -> liftM2 VarKernel get get

170+ 8 -> liftM2 VarKernel get get

155− 8 -> liftM List get

171+ 9 -> liftM List get

156− 9 -> liftM2 Function get get

172+ 10 -> liftM2 Function get get

157− 10 -> liftM2 Call get get

173+ 11 -> liftM2 Call get get

158− 11 -> liftM3 TailCall get get get

174+ 12 -> liftM3 TailCall get get get

159− 12 -> liftM2 If get get

175+ 13 -> liftM2 If get get

160− 13 -> liftM2 Let get get

176+ 14 -> liftM2 Let get get

161− 14 -> liftM3 Case get get get

177+ 15 -> liftM3 Case get get get

162− 15 -> liftM2 Ctor get get

163− 16 -> liftM2 CtorAccess get get

178+ 16 -> liftM2 Ctor get get

164− 17 -> liftM Accessor get

179+ 17 -> liftM2 CtorAccess get get

180+ 18 -> liftM Accessor get

165− 18 -> liftM2 Access get get

181+ 19 -> liftM2 Access get get

166− 19 -> liftM2 Update get get

182+ 20 -> liftM2 Update get get

167− 20 -> liftM Record get

183+ 21 -> liftM Record get

168− 21 -> pure Unit

184+ 22 -> pure Unit

169− 22 -> liftM3 Tuple get get get

185+ 23 -> liftM3 Tuple get get get

170− 23 -> liftM Shader get

186+ 24 -> liftM Shader get

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

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

172

188

173

189

src/Elm/Name.hs+13

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

3module Elm.Name

4 ( Name

5 , toString

6+ , localFromInt

7+ , toCompositeName

6 , int, float, bool, char, string

8 , int, float, bool, char, string

7 , maybe, list, array

9 , maybe, list, array

8 , task, router, cmd, sub

10 , task, router, cmd, sub

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

14import Prelude hiding (maybe, negate)

16import Prelude hiding (maybe, negate)

17+import qualified Data.Set as Set

15import qualified Data.Text as Text

18import qualified Data.Text as Text

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

27 Text.unpack

30 Text.unpack

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+

31-- COMMON NAMES

44-- COMMON NAMES

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

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

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3−module Optimize

3+module Optimize.Expression

4− ( optimizeExpr

4+ ( Cycle

5+ , optimize

6+ , destructArgs

7+ , optimizePotentialTailCall

5 )

8 )

6 where

9 where

12+import Prelude hiding (cycle)

9import Control.Monad (foldM)

13import Control.Monad (foldM)

14+import qualified Data.Set as Set

11import qualified AST.Canonical as Can

16import qualified AST.Canonical as Can

12import qualified AST.Optimized as Opt

17import qualified AST.Optimized as Opt

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

22-- OPTIMIZE

27-- OPTIMIZE

30+type Cycle =

31+ Set.Set N.Name

26−-- EXPRESSIONS

28−

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

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

30−optimizeExpr (A.At region expression) =

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

31 case expression of

36 case expression of

32 Can.VarLocal name ->

37 Can.VarLocal name ->

33 pure (Opt.VarLocal name)

38 pure (Opt.VarLocal name)

35 Can.VarTopLevel home name ->

40 Can.VarTopLevel home name ->

41+ if Set.member name cycle then

42+ pure (Opt.VarCycle home name)

43+ else

36− Names.registerGlobal home name

44+ Names.registerGlobal home name

38 Can.VarKernel home name ->

46 Can.VarKernel home name ->

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

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

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

60 pure (Opt.Float float)

68 pure (Opt.Float float)

62 Can.List entries ->

70 Can.List entries ->

63− Opt.List <$> traverse optimizeExpr entries

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

65 Can.Negate expr ->

73 Can.Negate expr ->

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

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

67− arg <- optimizeExpr expr

75+ arg <- optimize cycle expr

68 pure $ Opt.Call func [arg]

76 pure $ Opt.Call func [arg]

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

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

71 do optFunc <- Names.registerGlobal home name

79 do optFunc <- Names.registerGlobal home name

72− optLeft <- optimizeExpr left

80+ optLeft <- optimize cycle left

73− optRight <- optimizeExpr right

81+ optRight <- optimize cycle right

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

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

76 Can.Lambda args body ->

84 Can.Lambda args body ->

77 do (argNames, defss) <- destructArgs args

85 do (argNames, defss) <- destructArgs args

78− obody <- optimizeExpr body

86+ obody <- optimize cycle body

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

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

81 Can.Call func args ->

89 Can.Call func args ->

82 Opt.Call

90 Opt.Call

83− <$> optimizeExpr func

91+ <$> optimize cycle func

84− <*> traverse optimizeExpr args

92+ <*> traverse (optimize cycle) args

86 Can.If branches finally ->

94 Can.If branches finally ->

87 let

95 let

88 optimizeBranch (condition, branch) =

96 optimizeBranch (condition, branch) =

89 (,)

97 (,)

90− <$> optimizeExpr condition

98+ <$> optimize cycle condition

91− <*> optimizeExpr branch

99+ <*> optimize cycle branch

92 in

100 in

93 Opt.If

101 Opt.If

94 <$> traverse optimizeBranch branches

102 <$> traverse optimizeBranch branches

95− <*> optimizeExpr finally

103+ <*> optimize cycle finally

104

97 Can.Let def body ->

105 Can.Let def body ->

98− optimizeDef def =<< optimizeExpr body

106+ optimizeDef cycle def =<< optimize cycle body

107

100 Can.LetRec defs body ->

108 Can.LetRec defs body ->

101 case defs of

109 case defs of

102 [def] ->

110 [def] ->

103 Opt.Let

111 Opt.Let

104− <$> optimizePotentialTailCall def

112+ <$> optimizePotentialTailCall cycle def

105− <*> optimizeExpr body

113+ <*> optimize cycle body

106

114

107 _ ->

115 _ ->

108− do obody <- optimizeExpr body

116+ do obody <- optimize cycle body

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

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

110

118

111 Can.LetDestruct pattern expr body ->

119 Can.LetDestruct pattern expr body ->

112 do (name, defs) <- destruct pattern

120 do (name, defs) <- destruct pattern

113− oexpr <- optimizeExpr expr

121+ oexpr <- optimize cycle expr

114− obody <- optimizeExpr body

122+ obody <- optimize cycle body

115 pure $

123 pure $

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

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

117

125

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

119 let

127 let

120 optimizeBranch root (Can.CaseBranch pattern branch) =

128 optimizeBranch root (Can.CaseBranch pattern branch) =

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

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

122− obranch <- optimizeExpr branch

130+ obranch <- optimize cycle branch

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

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

124 in

132 in

125− do oexpr <- optimizeExpr expr

133+ do oexpr <- optimize cycle expr

126 case oexpr of

134 case oexpr of

127 Opt.VarLocal root ->

135 Opt.VarLocal root ->

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

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

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

135 Names.registerField field (Opt.Accessor field)

143 Names.registerField field (Opt.Accessor field)

136

144

137 Can.Access record field ->

145 Can.Access record field ->

138− do optRecord <- optimizeExpr record

146+ do optRecord <- optimize cycle record

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

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

140

148

141 Can.Update record updates ->

149 Can.Update record updates ->

142− Names.registerFields updates Opt.Update

150+ Names.registerFieldDict updates Opt.Update

143− <*> optimizeExpr record

151+ <*> optimize cycle record

144− <*> traverse optimizeExpr updates

152+ <*> traverse (optimize cycle) updates

145

153

146 Can.Record fields ->

154 Can.Record fields ->

147− Names.registerFields fields Opt.Record

155+ Names.registerFieldDict fields Opt.Record

148− <*> traverse optimizeExpr fields

156+ <*> traverse (optimize cycle) fields

149

157

150 Can.Unit ->

158 Can.Unit ->

151 Names.registerKernel N.utils Opt.Unit

159 Names.registerKernel N.utils Opt.Unit

152

160

153 Can.Tuple a b maybeC ->

161 Can.Tuple a b maybeC ->

154 Names.registerKernel N.utils Opt.Tuple

162 Names.registerKernel N.utils Opt.Tuple

155− <*> optimizeExpr a

163+ <*> optimize cycle a

156− <*> optimizeExpr b

164+ <*> optimize cycle b

157− <*> traverse optimizeExpr maybeC

165+ <*> traverse (optimize cycle) maybeC

158

166

159 Can.Shader _ src _ ->

167 Can.Shader _ src _ ->

160 pure (Opt.Shader src)

168 pure (Opt.Shader src)

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

164-- DEFINITION

172-- DEFINITION

165

173

166

174

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

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

168−optimizeDef def body =

176+optimizeDef cycle def body =

169 case def of

177 case def of

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

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

171− optimizeDefHelp name args expr body

179+ optimizeDefHelp cycle name args expr body

172

180

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

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

174− optimizeDefHelp name (map fst typedArgs) expr body

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

175

183

176

184

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

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

178−optimizeDefHelp name args expr body =

186+optimizeDefHelp cycle name args expr body =

179 case args of

187 case args of

180 [] ->

188 [] ->

181− do oexpr <- optimizeExpr expr

189+ do oexpr <- optimize cycle expr

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

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

183

191

184 _ ->

192 _ ->

185 do (argNames, defss) <- destructArgs args

193 do (argNames, defss) <- destructArgs args

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

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

187− pure $

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

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

189

196

190

197

191

198

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

223 pure (Opt.Def name root : revDefs)

230 pure (Opt.Def name root : revDefs)

224

231

225 Can.PRecord fields ->

232 Can.PRecord fields ->

226− let

227− addFieldDef defs name =

228− Names.registerField name $

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

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

230− in

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

231− foldM addFieldDef revDefs fields

232

235

233 Can.PAlias subPattern name ->

236 Can.PAlias subPattern name ->

234 destructHelp (Opt.VarLocal name) subPattern $

237 destructHelp (Opt.VarLocal name) subPattern $

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

294-- TAIL CALL

297-- TAIL CALL

295

298

296

299

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

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

298−optimizePotentialTailCall def =

301+optimizePotentialTailCall cycle def =

299 case def of

302 case def of

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

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

301 do (argNames, defss) <- destructArgs args

304 do (argNames, defss) <- destructArgs args

302 toTailDef name argNames defss <$>

305 toTailDef name argNames defss <$>

303− optimizeTailExpr name argNames expr

306+ optimizeTail cycle name argNames expr

304

307

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

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

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

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

307 toTailDef name argNames defss <$>

310 toTailDef name argNames defss <$>

308− optimizeTailExpr name argNames expr

311+ optimizeTail cycle name argNames expr

309

312

310

313

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

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

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

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

313 case expression of

316 case expression of

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

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

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

318 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

317 else

320 else

318− optimizeExpr locExpr

321+ optimize cycle locExpr

319

322

320 Can.If branches finally ->

323 Can.If branches finally ->

321 let

324 let

322 optimizeBranch (condition, branch) =

325 optimizeBranch (condition, branch) =

323 (,)

326 (,)

324− <$> optimizeExpr condition

327+ <$> optimize cycle condition

325− <*> optimizeTailExpr name argNames branch

328+ <*> optimizeTail cycle name argNames branch

326 in

329 in

327 Opt.If

330 Opt.If

328 <$> traverse optimizeBranch branches

331 <$> traverse optimizeBranch branches

329− <*> optimizeTailExpr name argNames finally

332+ <*> optimizeTail cycle name argNames finally

330

333

331 Can.Let def body ->

334 Can.Let def body ->

332− optimizeDef def =<< optimizeTailExpr name argNames body

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

333

336

334 Can.LetRec defs body ->

337 Can.LetRec defs body ->

335 case defs of

338 case defs of

336 [def] ->

339 [def] ->

337 Opt.Let

340 Opt.Let

338− <$> optimizePotentialTailCall def

341+ <$> optimizePotentialTailCall cycle def

339− <*> optimizeTailExpr name argNames body

342+ <*> optimizeTail cycle name argNames body

340

343

341 _ ->

344 _ ->

342− do obody <- optimizeTailExpr name argNames body

345+ do obody <- optimizeTail cycle name argNames body

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

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

344

347

345 Can.LetDestruct pattern expr body ->

348 Can.LetDestruct pattern expr body ->

346 do (dname, defs) <- destruct pattern

349 do (dname, defs) <- destruct pattern

347− oexpr <- optimizeExpr expr

350+ oexpr <- optimize cycle expr

348− obody <- optimizeTailExpr dname argNames body

351+ obody <- optimizeTail cycle dname argNames body

349 pure $

352 pure $

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

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

351

354

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

353 let

356 let

354 optimizeBranch root (Can.CaseBranch pattern branch) =

357 optimizeBranch root (Can.CaseBranch pattern branch) =

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

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

356− obranch <- optimizeTailExpr name argNames branch

359+ obranch <- optimizeTail cycle name argNames branch

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

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

358 in

361 in

359− do oexpr <- optimizeExpr expr

362+ do oexpr <- optimize cycle expr

360 case oexpr of

363 case oexpr of

361 Opt.VarLocal root ->

364 Opt.VarLocal root ->

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

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

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

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

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

367

370

368 _ ->

371 _ ->

369− optimizeExpr locExpr

372+ optimize cycle locExpr

370

373

371

374

372

375

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

7 , generate

8 , registerKernel

9 , registerGlobal

10− , registerFields

11 , registerField

10 , registerField

11+ , registerFieldDict

12+ , registerFieldList

12 )

13 )

13 where

14 where

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

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

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

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

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

74−registerFields newFields value =

75+registerFieldDict newFields value =

75 Tracker $ \n k g fields ok ->

76 Tracker $ \n k g fields ok ->

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

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

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

80toOne _ = 1

81toOne _ = 1

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+

84-- INSTANCES

96-- INSTANCES

src/Optimize/Port.hs+11−13

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

11import Prelude hiding (maybe, null)

12import Control.Monad (foldM)

13import qualified Data.Map as Map

14−import qualified Data.Text as Text

16import qualified AST.Canonical as Can

15import qualified AST.Canonical as Can

17import qualified AST.Optimized as Opt

16import qualified AST.Optimized as Opt

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

68 Can.TRecord fields Nothing ->

67 Can.TRecord fields Nothing ->

69 let

68 let

70− encodeField field fieldType =

69+ encodeField (name, fieldType) =

71 do encoder <- toEncoder fieldType

70 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

73 in

74− do record <- Map.traverseWithKey encodeField fields

74+ do object <- encode "object"

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

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

76+ Names.registerFieldDict fields $

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

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

266

268

267toLocal :: Int -> Opt.Expr

269toLocal :: Int -> Opt.Expr

268toLocal index =

270toLocal index =

269− Opt.VarLocal (indexToName index)

271+ Opt.VarLocal (N.localFromInt index)

270−

271−

272−indexToName :: Int -> N.Name

273−indexToName index =

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

275

272

276

273

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

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

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

281 typeDecoder <- toDecoder tipe

278 typeDecoder <- toDecoder tipe

282 return $

279 return $

283 Opt.Call andThen

280 Opt.Call andThen

284− [ Opt.Function [indexToName i] decoder

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

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

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

286 ]

283 ]

287

284

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

300 Opt.Record (Map.mapWithKey toFieldExpr fields)

297 Opt.Record (Map.mapWithKey toFieldExpr fields)

301 in

298 in

302 do succeed <- decode "succeed"

299 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)

304

302

305

303

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

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