833ed96 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Handle enums and boxed values in optimized AST

833ed96Evan Czaplicki9 years ago

src/AST/Optimized.hs+107−59

compare with master

unifiedsplit

@@ -4,6 +4,8 @@ module AST.Optimized

4 , Expr(..)

5 , Global(..)

6 , kernel

7+ , Path(..)

8+ , Destructor(..)

7 , Decider(..)

9 , Decider(..)

8 , Choice(..)

10 , Choice(..)

9 , Graph(..)

11 , Graph(..)

@@ -43,6 +45,8 @@ data Expr

43 | Float Double

45 | Float Double

44 | VarLocal N.Name

46 | VarLocal N.Name

45 | VarGlobal Global

47 | VarGlobal Global

48+ | VarEnum Global Index.ZeroBased

49+ | VarBox Global

46 | VarCycle ModuleName.Canonical N.Name

50 | VarCycle ModuleName.Canonical N.Name

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

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

48 | VarKernel N.Name N.Name

52 | VarKernel N.Name N.Name

@@ -52,8 +56,8 @@ data Expr

52 | TailCall N.Name [(N.Name, Expr)]

56 | TailCall N.Name [(N.Name, Expr)]

53 | If [(Expr, Expr)] Expr

57 | If [(Expr, Expr)] Expr

54 | Let Def Expr

58 | Let Def Expr

59+ | Destruct Destructor Expr

55 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]

60 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]

56− | Index Expr Int

57 | Accessor N.Name

61 | Accessor N.Name

58 | Access Expr N.Name

62 | Access Expr N.Name

59 | Update Expr (Map.Map N.Name Expr)

63 | Update Expr (Map.Map N.Name Expr)

@@ -83,6 +87,17 @@ data Def

83 | TailDef N.Name [N.Name] Expr

87 | TailDef N.Name [N.Name] Expr

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+

101

87-- BRANCHING

102-- BRANCHING

103

@@ -131,6 +146,8 @@ data Node

131 = Define Expr (Set.Set Global)

146 = Define Expr (Set.Set Global)

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

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

133 | Ctor N.Name Index.ZeroBased Int

148 | Ctor N.Name Index.ZeroBased Int

149+ | Enum N.Name Index.ZeroBased

150+ | Box N.Name

134 | Link Global

151 | Link Global

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

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

136 | Manager EffectsType

153 | Manager EffectsType

@@ -152,7 +169,7 @@ data KChunk

152 | JsVar N.Name N.Name

169 | JsVar N.Name N.Name

153 | ElmField N.Name

170 | ElmField N.Name

154 | JsField Int

171 | JsField Int

155− | Enum Int

172+ | JsEnum Int

156 | Debug

173 | Debug

157 | Prod

174 | Prod

158

175

@@ -175,24 +192,26 @@ instance Binary Expr where

175 Float a -> putWord8 3 >> put a

192 Float a -> putWord8 3 >> put a

176 VarLocal a -> putWord8 4 >> put a

193 VarLocal a -> putWord8 4 >> put a

177 VarGlobal a -> putWord8 5 >> put a

194 VarGlobal a -> putWord8 5 >> put a

178− VarCycle a b -> putWord8 6 >> put a >> put b

195+ VarEnum a b -> putWord8 6 >> put a >> put b

179− VarDebug a b c d -> putWord8 7 >> put a >> put b >> put c >> put d

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

180− VarKernel a b -> putWord8 8 >> put a >> put b

199+ VarKernel a b -> putWord8 10 >> put a >> put b

181− List a -> putWord8 9 >> put a

200+ List a -> putWord8 11 >> put a

182− Function a b -> putWord8 10 >> put a >> put b

201+ Function a b -> putWord8 12 >> put a >> put b

183− Call a b -> putWord8 11 >> put a >> put b

202+ Call a b -> putWord8 13 >> put a >> put b

184− TailCall a b -> putWord8 12 >> put a >> put b

203+ TailCall a b -> putWord8 14 >> put a >> put b

185− If a b -> putWord8 13 >> put a >> put b

204+ If a b -> putWord8 15 >> put a >> put b

186− Let a b -> putWord8 14 >> put a >> put b

205+ Let a b -> putWord8 16 >> 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

206+ Destruct a b -> putWord8 17 >> put a >> put b

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

207+ Case a b c d -> putWord8 18 >> put a >> put b >> put c >> put d

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

208+ Accessor a -> putWord8 19 >> put a

192− Record a -> putWord8 20 >> 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

193− Unit -> putWord8 21

212+ Unit -> putWord8 23

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

213+ Tuple a b c -> putWord8 24 >> put a >> put b >> put c

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

214+ Shader a -> putWord8 25 >> put a

196

215

197 get =

216 get =

198 do word <- getWord8

217 do word <- getWord8

@@ -203,24 +222,26 @@ instance Binary Expr where

203 3 -> liftM Float get

222 3 -> liftM Float get

204 4 -> liftM VarLocal get

223 4 -> liftM VarLocal get

205 5 -> liftM VarGlobal get

224 5 -> liftM VarGlobal get

206− 6 -> liftM2 VarCycle get get

225+ 6 -> liftM2 VarEnum get get

207− 7 -> liftM4 VarDebug get get get get

226+ 7 -> liftM VarBox get

208− 8 -> liftM2 VarKernel get get

227+ 8 -> liftM2 VarCycle get get

209− 9 -> liftM List get

228+ 9 -> liftM4 VarDebug get get get get

210− 10 -> liftM2 Function get get

229+ 10 -> liftM2 VarKernel get get

211− 11 -> liftM2 Call get get

230+ 11 -> liftM List get

212− 12 -> liftM2 TailCall get get

231+ 12 -> liftM2 Function get get

213− 13 -> liftM2 If get get

232+ 13 -> liftM2 Call get get

214− 14 -> liftM2 Let get get

233+ 14 -> liftM2 TailCall get get

215− 15 -> liftM4 Case get get get get

234+ 15 -> liftM2 If get get

216− 16 -> liftM2 Index get get

235+ 16 -> liftM2 Let get get

217− 17 -> liftM Accessor get

236+ 17 -> liftM2 Destruct get get

218− 18 -> liftM2 Access get get

237+ 18 -> liftM4 Case get get get get

219− 19 -> liftM2 Update get get

238+ 19 -> liftM Accessor get

220− 20 -> liftM Record get

239+ 20 -> liftM2 Access get get

240+ 21 -> liftM2 Update get get

241+ 22 -> liftM Record get

221− 21 -> pure Unit

242+ 23 -> pure Unit

222− 22 -> liftM3 Tuple get get get

243+ 24 -> liftM3 Tuple get get get

223− 23 -> liftM Shader get

244+ 25 -> liftM Shader get

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

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

225

246

226

247

@@ -238,6 +259,29 @@ instance Binary Def where

238 _ -> error "problem getting Opt.Def binary"

259 _ -> error "problem getting Opt.Def binary"

239

260

240

261

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+

241instance (Binary a) => Binary (Decider a) where

285instance (Binary a) => Binary (Decider a) where

242 put decider =

286 put decider =

243 case decider of

287 case decider of

@@ -291,29 +335,33 @@ instance Binary Main where

291instance Binary Node where

335instance Binary Node where

292 put node =

336 put node =

293 case node of

337 case node of

294− Define a b -> putWord8 0 >> put a >> put b

338+ Define a b -> putWord8 0 >> put a >> put b

295− DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c

339+ 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

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

297− Link a -> putWord8 3 >> put a

343+ Link a -> putWord8 5 >> put a

298− Cycle a b -> putWord8 4 >> put a >> put b

344+ Cycle a b -> putWord8 6 >> put a >> put b

299− Manager a -> putWord8 5 >> put a

345+ Manager a -> putWord8 7 >> put a

300− Kernel a b -> putWord8 6 >> put a >> put b

346+ Kernel a b -> putWord8 8 >> put a >> put b

301− PortIncoming a b -> putWord8 7 >> put a >> put b

347+ PortIncoming a b -> putWord8 9 >> put a >> put b

302− PortOutgoing a b -> putWord8 8 >> put a >> put b

348+ PortOutgoing a b -> putWord8 10 >> put a >> put b

303

349

304 get =

350 get =

305 do word <- getWord8

351 do word <- getWord8

306 case word of

352 case word of

307− 0 -> liftM2 Define get get

353+ 0 -> liftM2 Define get get

308− 1 -> liftM3 DefineTailFunc get get get

354+ 1 -> liftM3 DefineTailFunc get get get

309− 2 -> liftM3 Ctor get get get

355+ 2 -> liftM3 Ctor get get get

310− 3 -> liftM Link get

356+ 3 -> liftM2 Enum get get

357+ 4 -> liftM Box get

358+ 5 -> liftM Link get

311− 4 -> liftM2 Cycle get get

359+ 6 -> liftM2 Cycle get get

312− 5 -> liftM Manager get

360+ 7 -> liftM Manager get

313− 6 -> liftM2 Kernel get get

361+ 8 -> liftM2 Kernel get get

314− 7 -> liftM2 PortIncoming get get

362+ 9 -> liftM2 PortIncoming get get

315− 8 -> liftM2 PortOutgoing get get

363+ 10 -> liftM2 PortOutgoing get get

316− _ -> error "problem getting Opt.Node binary"

364+ _ -> error "problem getting Opt.Node binary"

317

365

318

366

319instance Binary EffectsType where

367instance Binary EffectsType where

@@ -345,7 +393,7 @@ instance Binary KChunk where

345 JsVar a b -> putWord8 2 >> put a >> put b

393 JsVar a b -> putWord8 2 >> put a >> put b

346 ElmField a -> putWord8 3 >> put a

394 ElmField a -> putWord8 3 >> put a

347 JsField a -> putWord8 4 >> put a

395 JsField a -> putWord8 4 >> put a

348− Enum a -> putWord8 5 >> put a

396+ JsEnum a -> putWord8 5 >> put a

349 Debug -> putWord8 6

397 Debug -> putWord8 6

350 Prod -> putWord8 7

398 Prod -> putWord8 7

351

399

@@ -357,7 +405,7 @@ instance Binary KChunk where

357 2 -> liftM2 JsVar get get

405 2 -> liftM2 JsVar get get

358 3 -> liftM ElmField get

406 3 -> liftM ElmField get

359 4 -> liftM JsField get

407 4 -> liftM JsField get

360− 5 -> liftM Enum get

408+ 5 -> liftM JsEnum get

361 6 -> return Debug

409 6 -> return Debug

362 7 -> return Prod

410 7 -> return Prod

363 _ -> error "problem deserializing AST.Optimized.KChunk"

411 _ -> error "problem deserializing AST.Optimized.KChunk"

src/Optimize/DecisionTree.hs+92−94

@@ -21,7 +21,7 @@ as SML/NJ to get nice trees.

21-}

23import Control.Arrow (second)

24−import Control.Monad (liftM, liftM2, liftM3)

24+import Control.Monad (liftM, liftM2, liftM4)

25import Data.Binary

26import qualified Data.List as List

27import qualified Data.Maybe as Maybe

@@ -71,7 +71,9 @@ data DecisionTree

73data Test

74− = IsCtor Int N.Name Index.ZeroBased

74+ = IsCtor N.Name Index.ZeroBased Int Can.CtorOpts

75+ | IsCons

76+ | IsNil

75 | IsInt Int

77 | IsInt Int

76 | IsChr Text

78 | IsChr Text

77 | IsStr Text

79 | IsStr Text

@@ -79,42 +81,13 @@ data Test

81data Path

83data Path

82− = Index Int Path

84+ = Index Index.ZeroBased Path

83− | Field N.Name Path

85+ | Unbox Path

84 | Empty

86 | Empty

85− | Alias

86 deriving (Eq)

87 deriving (Eq)

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−

118-- ACTUALLY BUILD DECISION TREES

91-- ACTUALLY BUILD DECISION TREES

119

120

@@ -163,8 +136,14 @@ toDecisionTree rawBranches =

163isComplete :: [Test] -> Bool

136isComplete :: [Test] -> Bool

164isComplete tests =

137isComplete tests =

165 case head tests of

138 case head tests of

166− IsCtor alts _ _ ->

139+ IsCtor _ _ numAlts _ ->

140+ numAlts == length tests

141+

142+ IsCons ->

143+ length tests == 2

144+

145+ IsNil ->

167− alts == length tests

146+ length tests == 2

168

147

169 _ ->

148 _ ->

170 False

149 False

@@ -191,29 +170,32 @@ flatten pathPattern@(path, A.At region pattern) =

191 Can.PAnything ->

170 Can.PAnything ->

192 [pathPattern]

171 [pathPattern]

193

172

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−

205 Can.PTuple a b Nothing ->

173 Can.PTuple a b Nothing ->

206 concatMap flatten (subPositions path [a,b])

174 concatMap flatten (subPositions path [a,b])

207

175

208 Can.PTuple a b (Just c) ->

176 Can.PTuple a b (Just c) ->

209 concatMap flatten (subPositions path [a,b,c])

177 concatMap flatten (subPositions path [a,b,c])

210

178

211− Can.PCtor _ _ _ (Can.CtorAlts numAlts _) _ _ args ->

179+ Can.PCtor _ _ (Can.Union _ _ 1 _) _ _ ctorArgs ->

212− if numAlts == 1 then

180+ case map dearg ctorArgs of

213− concatMap flatten (subPositions path (map dearg args))

181+ [arg] ->

214− else

182+ flatten (Unbox path, arg)

183+

184+ args ->

185+ concatMap flatten (subPositions path args)

186+

187+ Can.PCtor _ _ _ _ _ _ ->

215 [pathPattern]

188 [pathPattern]

216

189

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+

217 Can.PList _ ->

199 Can.PList _ ->

218 [pathPattern]

200 [pathPattern]

219

201

@@ -230,6 +212,11 @@ flatten pathPattern@(path, A.At region pattern) =

230 [pathPattern]

212 [pathPattern]

231

213

232

214

215+subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]

216+subPositions path patterns =

217+ Index.indexedMap (\index pattern -> (Index index path, pattern)) patterns

218+

219+

233dearg :: Can.PatternCtorArg -> Can.Pattern

220dearg :: Can.PatternCtorArg -> Can.Pattern

234dearg (Can.PatternCtorArg _ _ pattern) =

221dearg (Can.PatternCtorArg _ _ pattern) =

235 pattern

222 pattern

@@ -305,8 +292,8 @@ testAtPath selectedPath (Branch _ pathPatterns) =

305

292

306 Just (A.At _ pattern) ->

293 Just (A.At _ pattern) ->

307 case pattern of

294 case pattern of

308− Can.PCtor _ _ _ (Can.CtorAlts numAlts _) name index _ ->

295+ Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->

309− Just (IsCtor numAlts name index)

296+ Just (IsCtor name index numAlts opts)

310

297

311 Can.PInt int ->

298 Can.PInt int ->

312 Just (IsInt int)

299 Just (IsInt int)

@@ -318,13 +305,13 @@ testAtPath selectedPath (Branch _ pathPatterns) =

318 Just (IsChr chr)

305 Just (IsChr chr)

319

306

320 Can.PList [] ->

307 Can.PList [] ->

321− Just nilTest

308+ Just IsNil

322

309

323 Can.PList _ ->

310 Can.PList _ ->

324− Just consTest

311+ Just IsCons

325

312

326 Can.PCons _ _ ->

313 Can.PCons _ _ ->

327− Just consTest

314+ Just IsCons

328

315

329 Can.PVar _ ->

316 Can.PVar _ ->

330 Nothing

317 Nothing

@@ -345,16 +332,6 @@ testAtPath selectedPath (Branch _ pathPatterns) =

345 Nothing

332 Nothing

346

333

347

334

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−

358

335

359-- BUILD EDGES

336-- BUILD EDGES

360

337

@@ -371,47 +348,66 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

371 case extract path pathPatterns of

348 case extract path pathPatterns of

372 Just (start, A.At region pattern, end) ->

349 Just (start, A.At region pattern, end) ->

373 case pattern of

350 case pattern of

374− Can.PCtor _ _ _ (Can.CtorAlts numAlts _) name index args ->

351+ Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->

375− if test == IsCtor numAlts name index then

352+ case test of

353+ IsCtor testName _ _ _ | name == testName ->

376− Just (Branch goal (start ++ subPositions path (map dearg args) ++ end))

354+ Just $ Branch goal $

377− else

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+ _ ->

378 Nothing

363 Nothing

379

364

380 Can.PList [] ->

365 Can.PList [] ->

381− if test == nilTest then

366+ case test of

367+ IsNil ->

382 Just (Branch goal (start ++ end))

368 Just (Branch goal (start ++ end))

383− else

369+

370+ _ ->

384 Nothing

371 Nothing

385

372

386 Can.PList (hd:tl) ->

373 Can.PList (hd:tl) ->

387− if test == consTest then

374+ case test of

375+ IsCons ->

388 let tl' = A.At region (Can.PList tl) in

376 let tl' = A.At region (Can.PList tl) in

389 Just (Branch goal (start ++ subPositions path [ hd, tl' ] ++ end))

377 Just (Branch goal (start ++ subPositions path [ hd, tl' ] ++ end))

390− else

378+

379+ _ ->

391 Nothing

380 Nothing

392

381

393 Can.PCons hd tl ->

382 Can.PCons hd tl ->

394− if test == consTest then

383+ case test of

384+ IsCons ->

395 Just (Branch goal (start ++ subPositions path [hd,tl] ++ end))

385 Just (Branch goal (start ++ subPositions path [hd,tl] ++ end))

396− else

386+

387+ _ ->

397 Nothing

388 Nothing

398

389

399 Can.PChr chr ->

390 Can.PChr chr ->

391+ case test of

400− if test == IsChr chr then

392+ IsChr testChr | chr == testChr ->

401 Just (Branch goal (start ++ end))

393 Just (Branch goal (start ++ end))

402− else

394+ _ ->

403 Nothing

395 Nothing

404

396

405 Can.PStr str ->

397 Can.PStr str ->

398+ case test of

406− if test == IsStr str then

399+ IsStr testStr | str == testStr ->

407 Just (Branch goal (start ++ end))

400 Just (Branch goal (start ++ end))

408− else

401+

402+ _ ->

409 Nothing

403 Nothing

410

404

411 Can.PInt int ->

405 Can.PInt int ->

406+ case test of

412− if test == IsInt int then

407+ IsInt testInt | int == testInt ->

413 Just (Branch goal (start ++ end))

408 Just (Branch goal (start ++ end))

414− else

409+

410+ _ ->

415 Nothing

411 Nothing

416

412

417 _ ->

413 _ ->

@@ -472,7 +468,7 @@ needsTests (A.At _ pattern) =

472 Can.PRecord _ ->

468 Can.PRecord _ ->

473 False

469 False

474

470

475− Can.PCtor _ _ _ _ _ _ _ ->

471+ Can.PCtor _ _ _ _ _ _ ->

476 True

472 True

477

473

478 Can.PList _ ->

474 Can.PList _ ->

@@ -574,18 +570,22 @@ smallBranchingFactor branches path =

574instance Binary Test where

570instance Binary Test where

575 put test =

571 put test =

576 case test of

572 case test of

577− IsCtor a b c -> putWord8 0 >> put a >> put b >> put c

573+ IsCtor a b c d -> putWord8 0 >> put a >> put b >> put c >> put d

574+ IsCons -> putWord8 1

575+ IsNil -> putWord8 2

578− IsChr a -> putWord8 1 >> put a

576+ IsChr a -> putWord8 3 >> put a

579− IsStr a -> putWord8 2 >> put a

577+ IsStr a -> putWord8 4 >> put a

580− IsInt a -> putWord8 3 >> put a

578+ IsInt a -> putWord8 5 >> put a

581

579

582 get =

580 get =

583 do word <- getWord8

581 do word <- getWord8

584 case word of

582 case word of

585− 0 -> liftM3 IsCtor get get get

583+ 0 -> liftM4 IsCtor get get get get

584+ 1 -> pure IsCons

585+ 2 -> pure IsNil

586− 1 -> liftM IsChr get

586+ 3 -> liftM IsChr get

587− 2 -> liftM IsStr get

587+ 4 -> liftM IsStr get

588− 3 -> liftM IsInt get

588+ 5 -> liftM IsInt get

589 _ -> error "problem getting DecisionTree.Test binary"

590

591

@@ -593,15 +593,13 @@ instance Binary Path where

593 put path =

594 case path of

595 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

597 Empty -> putWord8 2

598− Alias -> putWord8 3

599

598

600 get =

599 get =

601 do word <- getWord8

600 do word <- getWord8

602 case word of

601 case word of

603 0 -> liftM2 Index get get

602 0 -> liftM2 Index get get

604− 1 -> liftM2 Field get get

603+ 1 -> liftM Unbox get

605 2 -> pure Empty

604 2 -> pure Empty

606− 3 -> pure Alias

607 _ -> error "problem getting DecisionTree.Path binary"

605 _ -> error "problem getting DecisionTree.Path binary"

src/Optimize/Expression.hs+68−65

@@ -49,6 +49,9 @@ optimize cycle (A.At region expression) =

49 Can.VarForeign home name _ ->

50 Names.registerGlobal home name

52+ Can.VarCtor opts home name index _ ->

53+ Names.registerCtor home name index opts

54+

52 Can.VarDebug home name _ ->

55 Can.VarDebug home name _ ->

53 Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)

56 Names.registerKernel N.debug (Opt.VarDebug name home region Nothing)

@@ -82,9 +85,9 @@ optimize cycle (A.At region expression) =

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

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

84 Can.Lambda args body ->

87 Can.Lambda args body ->

85− do (argNames, defss) <- destructArgs args

88+ do (argNames, destructors) <- destructArgs args

86 obody <- optimize cycle body

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

89 Can.Call func args ->

92 Can.Call func args ->

90 Opt.Call

93 Opt.Call

@@ -117,18 +120,18 @@ optimize cycle (A.At region expression) =

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

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

118

121

119 Can.LetDestruct pattern expr body ->

122 Can.LetDestruct pattern expr body ->

120− do (name, defs) <- destruct pattern

123+ do (name, destructs) <- destruct pattern

121 oexpr <- optimize cycle expr

124 oexpr <- optimize cycle expr

122 obody <- optimize cycle body

125 obody <- optimize cycle body

123 pure $

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

125

128

126 Can.Case expr branches ->

129 Can.Case expr branches ->

127 let

130 let

128 optimizeBranch root (Can.CaseBranch pattern branch) =

131 optimizeBranch root (Can.CaseBranch pattern branch) =

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

132+ do destructors <- destructHelp (Opt.Root root) pattern []

130 obranch <- optimize cycle branch

133 obranch <- optimize cycle branch

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

134+ pure (pattern, foldr Opt.Destruct obranch destructors)

132 in

135 in

133 do temp <- Names.generate

136 do temp <- Names.generate

134 oexpr <- optimize cycle expr

137 oexpr <- optimize cycle expr

@@ -190,8 +193,8 @@ optimizeDefHelp cycle name args expr body =

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

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

191

194

192 _ ->

195 _ ->

193− do (argNames, defss) <- destructArgs args

196+ do (argNames, destructors) <- destructArgs args

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

197+ let oexpr = Opt.Function argNames (foldr Opt.Destruct body destructors)

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

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

196

199

197

200

@@ -199,98 +202,98 @@ optimizeDefHelp cycle name args expr body =

199-- DESTRUCTURING

202-- DESTRUCTURING

200

203

201

204

202−destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [[Opt.Def]])

205+destructArgs :: [Can.Pattern] -> Names.Tracker ([N.Name], [Opt.Destructor])

203destructArgs args =

206destructArgs args =

204− unzip <$> traverse destruct args

207+ do (argNames, destructorLists) <- unzip <$> traverse destruct args

208+ return (argNames, concat destructorLists)

205

209

206

210

207−destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Def])

211+destruct :: Can.Pattern -> Names.Tracker (N.Name, [Opt.Destructor])

208destruct pattern@(A.At _ ptrn) =

212destruct pattern@(A.At _ ptrn) =

209 case ptrn of

213 case ptrn of

210 Can.PVar name ->

214 Can.PVar name ->

211 pure (name, [])

215 pure (name, [])

212

216

213 Can.PAlias subPattern name ->

217 Can.PAlias subPattern name ->

214− do revDefs <- destructHelp (Opt.VarLocal name) subPattern []

218+ do revDs <- destructHelp (Opt.Root name) subPattern []

215− pure (name, reverse revDefs)

219+ pure (name, reverse revDs)

216

220

217 _ ->

221 _ ->

218 do name <- Names.generate

222 do name <- Names.generate

219− revDefs <- destructHelp (Opt.VarLocal name) pattern []

223+ revDs <- destructHelp (Opt.Root name) pattern []

220− pure (name, reverse revDefs)

224+ pure (name, reverse revDs)

221

225

222

226

223−destructHelp :: Opt.Expr -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]

227+destructHelp :: Opt.Path -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]

224−destructHelp root (A.At region pattern) revDefs =

228+destructHelp path (A.At region pattern) revDs =

225 case pattern of

229 case pattern of

226 Can.PAnything ->

230 Can.PAnything ->

227− pure revDefs

231+ pure revDs

228

232

229 Can.PVar name ->

233 Can.PVar name ->

230− pure (Opt.Def name root : revDefs)

234+ pure (Opt.Destructor name path : revDs)

231

235

232 Can.PRecord fields ->

236 Can.PRecord fields ->

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

237+ let

238+ toDestruct name =

239+ Opt.Destructor name (Opt.Field name path)

240+ in

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

241+ Names.registerFieldList fields (map toDestruct fields ++ revDs)

235

242

236 Can.PAlias subPattern name ->

243 Can.PAlias subPattern name ->

237− destructHelp (Opt.VarLocal name) subPattern $

244+ destructHelp (Opt.Root name) subPattern $

238− Opt.Def name root : revDefs

245+ Opt.Destructor name path : revDs

239

246

240 Can.PUnit ->

247 Can.PUnit ->

241− pure revDefs

248+ pure revDs

249+

250+ Can.PTuple a b Nothing ->

251+ destructTwo path a b revDs

242

252

243− Can.PTuple a b maybeC ->

253+ Can.PTuple a b (Just c) ->

244 do name <- Names.generate

254 do name <- Names.generate

245− let tuple = Opt.VarLocal name

255+ let newRoot = Opt.Root name

246− let newRevDefs = Opt.Def name root : revDefs

256+ destructHelp (Opt.Index Index.first newRoot) a =<<

247− case maybeC of

257+ destructHelp (Opt.Index Index.second newRoot) b =<<

248− Nothing ->

258+ destructHelp (Opt.Index Index.third newRoot) c (Opt.Destructor name path : revDs)

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

256

259

257 Can.PList [] ->

260 Can.PList [] ->

258− pure revDefs

261+ pure revDs

259

262

260 Can.PList (hd:tl) ->

263 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

262

265

263 Can.PCons hd tl ->

266 Can.PCons hd tl ->

264− destructCons root hd tl revDefs

267+ destructTwo path hd tl revDs

265

268

266 Can.PChr _ ->

269 Can.PChr _ ->

267− pure revDefs

270+ pure revDs

268

271

269 Can.PStr _ ->

272 Can.PStr _ ->

270− pure revDefs

273+ pure revDs

271

274

272 Can.PInt _ ->

275 Can.PInt _ ->

273− pure revDefs

276+ pure revDs

274

277

275− Can.PCtor _ _ _ _ _ _ args ->

278+ Can.PCtor _ _ _ _ _ args ->

276 do name <- Names.generate

279 do name <- Names.generate

277 foldM

280 foldM

278− (destructCtorArg (Opt.VarLocal name))

281+ (destructCtorArg (Opt.Root name))

279− (Opt.Def name root : revDefs)

282+ (Opt.Destructor name path : revDs)

280 args

283 args

281

284

282

285

283−destructCons :: Opt.Expr -> Can.Pattern -> Can.Pattern -> [Opt.Def] -> Names.Tracker [Opt.Def]

286+destructTwo :: Opt.Path -> Can.Pattern -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]

284−destructCons root hd tl revDefs =

287+destructTwo path a b revDs =

285 do name <- Names.generate

288 do name <- Names.generate

286− let list = Opt.VarLocal name

289+ let newRoot = Opt.Root name

287− destructHelp (Opt.Index list 0) hd =<<

290+ destructHelp (Opt.Index Index.first newRoot) a =<<

288− destructHelp (Opt.Index list 1) tl (Opt.Def name root : revDefs)

291+ destructHelp (Opt.Index Index.second newRoot) b (Opt.Destructor name path : revDs)

289

292

290

293

291−destructCtorArg :: Opt.Expr -> [Opt.Def] -> Can.PatternCtorArg -> Names.Tracker [Opt.Def]

294+destructCtorArg :: Opt.Path -> [Opt.Destructor] -> Can.PatternCtorArg -> Names.Tracker [Opt.Destructor]

292−destructCtorArg root revDefs (Can.PatternCtorArg index _ arg) =

295+destructCtorArg path revDs (Can.PatternCtorArg index _ arg) =

293− destructHelp (Opt.Index root (Index.toZeroBased index)) arg revDefs

296+ destructHelp (Opt.Index index path) arg revDs

294

297

295

298

296

299

@@ -301,13 +304,13 @@ optimizePotentialTailCall :: Cycle -> Can.Def -> Names.Tracker Opt.Def

301optimizePotentialTailCall cycle def =

304optimizePotentialTailCall cycle def =

302 case def of

305 case def of

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

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

304− do (argNames, defss) <- destructArgs args

307+ do (argNames, destructors) <- destructArgs args

305− toTailDef name argNames defss <$>

308+ toTailDef name argNames destructors <$>

306 optimizeTail cycle name argNames expr

309 optimizeTail cycle name argNames expr

307

310

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

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

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

312+ do (argNames, destructors) <- destructArgs (map fst typedArgs)

310− toTailDef name argNames defss <$>

313+ toTailDef name argNames destructors <$>

311 optimizeTail cycle name argNames expr

314 optimizeTail cycle name argNames expr

312

315

313

316

@@ -355,18 +358,18 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) =

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

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

356

359

357 Can.LetDestruct pattern expr body ->

360 Can.LetDestruct pattern expr body ->

358− do (dname, defs) <- destruct pattern

361+ do (dname, destructors) <- destruct pattern

359 oexpr <- optimize cycle expr

362 oexpr <- optimize cycle expr

360 obody <- optimizeTail cycle dname argNames body

363 obody <- optimizeTail cycle dname argNames body

361 pure $

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

363

366

364 Can.Case expr branches ->

367 Can.Case expr branches ->

365 let

368 let

366 optimizeBranch root (Can.CaseBranch pattern branch) =

369 optimizeBranch root (Can.CaseBranch pattern branch) =

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

370+ do destructors <- destructHelp (Opt.Root root) pattern []

368 obranch <- optimizeTail cycle rootName argNames branch

371 obranch <- optimizeTail cycle rootName argNames branch

369− pure (pattern, foldr Opt.Let obranch defs)

372+ pure (pattern, foldr Opt.Destruct obranch destructors)

370 in

373 in

371 do temp <- Names.generate

374 do temp <- Names.generate

372 oexpr <- optimize cycle expr

375 oexpr <- optimize cycle expr

@@ -385,12 +388,12 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) =

385-- DETECT TAIL CALLS

388-- DETECT TAIL CALLS

386

389

387

390

388−toTailDef :: N.Name -> [N.Name] -> [[Opt.Def]] -> Opt.Expr -> Opt.Def

391+toTailDef :: N.Name -> [N.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def

389−toTailDef name argNames defss body =

392+toTailDef name argNames destructors body =

390 if hasTailCall body then

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

392 else

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

394

397

395

398

396hasTailCall :: Opt.Expr -> Bool

399hasTailCall :: Opt.Expr -> Bool

src/Optimize/Module.hs+8−9

@@ -9,13 +9,13 @@ module Optimize.Module

10import Prelude hiding (cycle)

11import Control.Monad (foldM)

12+import qualified Data.List as List

12import qualified Data.Map as Map

13import qualified Data.Map as Map

13import qualified Data.Set as Set

14import qualified Data.Set as Set

15import qualified AST.Canonical as Can

16import qualified AST.Canonical as Can

16import qualified AST.Optimized as Opt

17import qualified AST.Optimized as Opt

17import qualified AST.Module.Name as ModuleName

18import qualified AST.Module.Name as ModuleName

18−import qualified Data.Index as Index

19import qualified Elm.Name as N

20import qualified Optimize.Expression as Expr

21import qualified Optimize.Names as Names

@@ -58,14 +58,13 @@ addUnions home unions (Graph fields nodes) =

60addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes

61−addUnion home (Can.Union _ ctors) nodes =

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

62− Map.union nodes $

62+ List.foldl' (addCtorNode home) nodes ctors

63− Map.fromList (Index.indexedMap (ctorToNode home) ctors)

66−ctorToNode :: ModuleName.Canonical -> Index.ZeroBased -> (N.Name, [t]) -> (Opt.Global, Opt.Node)

65+addCtorNode :: ModuleName.Canonical -> Nodes -> Can.Ctor -> Nodes

67−ctorToNode home index (name, args) =

66+addCtorNode home nodes (Can.Ctor name index numArgs _) =

68− ( Opt.Global home name, Opt.Ctor name index (length args) )

67+ Map.insert (Opt.Global home name) (Opt.Ctor name index numArgs) nodes

@@ -207,10 +206,10 @@ addDefHelp name args body graph =

207 let

206 let

208 (deps, fields, function) =

207 (deps, fields, function) =

209 Names.run $

208 Names.run $

210− do (argNames, defss) <- Expr.destructArgs args

209+ do (argNames, destructors) <- Expr.destructArgs args

211 obody <- Expr.optimize Set.empty body

210 obody <- Expr.optimize Set.empty body

212 pure $ Opt.Function argNames $

211 pure $ Opt.Function argNames $

213− foldr Opt.Let obody (concat defss)

212+ foldr Opt.Destruct obody destructors

214 in

213 in

215 addToGraph name (Opt.Define function deps) fields graph

214 addToGraph name (Opt.Define function deps) fields graph

216

215

src/Optimize/Names.hs+26

@@ -7,6 +7,7 @@ module Optimize.Names

7 , generate

8 , registerKernel

9 , registerGlobal

10+ , registerCtor

10 , registerField

11 , registerField

11 , registerFieldDict

12 , registerFieldDict

12 , registerFieldList

13 , registerFieldList

@@ -19,8 +20,10 @@ import qualified Data.Map as Map

19import qualified Data.Set as Set

20import qualified Data.Set as Set

20import qualified Data.Text as Text

21import qualified Data.Text as Text

23+import qualified AST.Canonical as Can

22import qualified AST.Optimized as Opt

24import qualified AST.Optimized as Opt

23import qualified AST.Module.Name as ModuleName

25import qualified AST.Module.Name as ModuleName

26+import qualified Data.Index as Index

24import qualified Elm.Name as N

27import qualified Elm.Name as N

25import qualified Elm.Package as Pkg

28import qualified Elm.Package as Pkg

@@ -70,6 +73,29 @@ registerGlobal home name =

70 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)

73 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)

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+

73registerField :: N.Name -> a -> Tracker a

99registerField :: N.Name -> a -> Tracker a

74registerField name value =

100registerField name value =

75 Tracker $ \uid d fields ok ->

101 Tracker $ \uid d fields ok ->

src/Optimize/Port.hs+22−20

@@ -18,7 +18,6 @@ import qualified AST.Module.Name as ModuleName

18import qualified AST.Utils.Type as Type

19import qualified Data.Index as Index

20import qualified Elm.Name as N

21−import qualified Optimize.DecisionTree as DT

22import qualified Optimize.Names as Names

21import qualified Optimize.Names as Names

@@ -85,13 +84,9 @@ encodeMaybe :: Can.Type -> Names.Tracker Opt.Expr

85encodeMaybe tipe =

84encodeMaybe tipe =

86 do null <- encode "null"

85 do null <- encode "null"

87 encoder <- toEncoder tipe

86 encoder <- toEncoder tipe

88−

87+ destruct <- Names.registerGlobal ModuleName.maybe "destruct"

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−

93 return $ Opt.Function [N.dollar] $

88 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 ]

97encodeList :: Can.Type -> Names.Tracker Opt.Expr

92encodeList :: Can.Type -> Names.Tracker Opt.Expr

@@ -117,21 +112,28 @@ encodeArray tipe =

117encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr

112encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr

118encodeTuple a b maybeC =

113encodeTuple a b maybeC =

119 let

114 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 =

121 do encoder <- toEncoder tipe

119 do encoder <- toEncoder tipe

122− return $ Opt.Call encoder [ Opt.Index (Opt.VarLocal N.dollar) index ]

120+ return $ Opt.Call encoder [ Opt.VarLocal arg ]

123 in

121 in

122+ do list <- encode "list"

123+ arg1 <- encodeArg "a" a

124+ arg2 <- encodeArg "b" b

125+

124− Opt.Function [N.dollar] <$> (

126+ Opt.Function [N.dollar] <$>

125− Opt.Call

127+ let_ "a" Index.first <$>

126− <$> encode "list"

128+ let_ "b" Index.second <$>

127− <*>

128− case maybeC of

129+ case maybeC of

129− Nothing ->

130+ Nothing ->

130− sequence [ convert 0 a, convert 1 b ]

131+ return $ Opt.Call list [ arg1, arg2 ]

131−

132+

132− Just c ->

133+ Just c ->

133− sequence [ convert 0 a, convert 1 b, convert 2 c ]

134+ do arg3 <- encodeArg "c" c

134− )

135+ return $ let_ "c" Index.third $

136+ Opt.Call list [ arg1, arg2, arg3 ]

135

137

136

138

137

139