f4a182c · elk · git.iko.soy

git.iko.soy/elk

Put inlined version of Case into optimized AST

commitf4a182cb788bf3e1b38d1ffa9d9f2b664e2a80b4 authorEvan Czaplicki <info@elm-lang.org> dateFri 4 Sep 2015, 18:51 (11 years ago) parent87dc670

4 files changed+160−49

compare with master

unifiedsplit

src/AST/Expression/Optimized.hs+28−14 src/Generate/JavaScript.hs+4−4 src/Optimize.hs+115−20 src/Optimize/Cases.hs+13−11

src/AST/Expression/Optimized.hs+28−14

@@ -1,20 +1,34 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Optimized

3− ( Expr(..)

4− , Def(..)

5− , Facts(..)

3+ ( Def(..), Facts(..)

4+ , Expr(..), Jump(..), Branch(..)

65 ) where

8−import qualified Data.Map as Map

9−

107import qualified AST.Expression.General as General

118import qualified AST.Literal as Literal

129import qualified AST.Module.Name as ModuleName

1310import qualified AST.Type as Type

1411import qualified AST.Variable as Var

1512import qualified Optimize.Cases as PM

13+import qualified Reporting.Region as R

14+

15+

16+

17+-- DEFINITIONS

18+

19+data Def

20+ = Def Facts String Expr

21+ | TailDef Facts String [String] Expr

22+

23+

24+data Facts = Facts

25+ { home :: Maybe ModuleName.Canonical

26+ , dependencies :: [Var.TopLevel]

27+ }

1628

1729

30+-- EXPRESSIONS

31+

1832data Expr

1933 = Literal Literal.Literal

2034 | Var Var.Canonical

@@ -26,7 +40,7 @@ data Expr

2640 | TailCall String [String] [Expr]

2741 | If [(Expr, Expr)] Expr

2842 | Let [Def] Expr

29− | Case Expr (PM.DecisionTree Int) (Map.Map Int Expr)

43+ | Case Expr (PM.DecisionTree Jump) [(Int, Branch)]

3044 | Data String [Expr]

3145 | DataAccess Expr Int

3246 | Access Expr String

@@ -34,15 +48,15 @@ data Expr

3448 | Record [(String, Expr)]

3549 | Port (General.PortImpl Expr Type.Canonical)

3650 | GLShader String String Literal.GLShaderTipe

37− | Crash

51+ | Crash R.Region (Maybe String)

3852

3953

40−data Def

41− = Def Facts String Expr

42− | TailDef Facts String [String] Expr

54+data Jump

55+ = Inline Branch

56+ | Jump Int

4357

4458

45−data Facts = Facts

46− { home :: Maybe ModuleName.Canonical

47− , dependencies :: [Var.TopLevel]

48− }

59+data Branch = Branch

60+ { _substitutions :: [(String, PM.Path)]

61+ , _branch :: Expr

62+ }

src/Generate/JavaScript.hs+4−4

@@ -230,7 +230,7 @@ generateCode expr =

230230 do expr' <- generateJsExpr expr

231231 jsExpr (Port.task name expr' portType)

232232

233− Crash ->

233+ Crash _ _ ->

234234 error "TODO"

235235

236236

@@ -330,11 +330,11 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

330330

331331generateCase

332332 :: Opt.Expr

333− -> PM.DecisionTree Int

334− -> Map.Map Int Opt.Expr

333+ -> PM.DecisionTree Opt.Jump

334+ -> [(Int, Opt.Branch)]

335335 -> State Int Code

336336generateCase expr decisionTree branches =

337− error "TODO" expr decisionTree branches

337+ error "TODO"

338338

339339

340340-- BINARY OPERATORS

src/Optimize.hs+115−20

@@ -1,9 +1,12 @@

11module Optimize (optimize) where

33import Control.Applicative

4+import Control.Arrow (second)

45import qualified Control.Monad as M

56import qualified Control.Monad.State as State

67import qualified Data.Map as Map

8+import Data.Map ((!))

9+import qualified Data.Maybe as Maybe

710import qualified Data.Traversable as T

811

912import qualified AST.Expression.General as Expr

@@ -13,6 +16,7 @@ import qualified AST.Module as Module

1316import qualified AST.Module.Name as ModuleName

1417import qualified AST.Pattern as P

1518import qualified AST.Variable as Var

19+import Elm.Utils ((|>))

1620import qualified Optimize.Cases as Cases

1721import qualified Reporting.Annotation as A

1822import qualified Reporting.Region as R

@@ -270,26 +274,8 @@ optimizeExpr context annExpr@(A.A region expression) =

270274 do optDefs <- concat <$> T.traverse (optimizeDef Nothing) defs

271275 Opt.Let optDefs <$> keepLooking body

272276

273− Expr.Case expr rawBranches ->

274− let

275− indexify index (pattern, branch) =

276− ( (pattern, index)

277− , (index, branch)

278− )

279−

280− (patterns, indexedBranches) =

281− unzip (zipWith indexify [0..] rawBranches)

282−

283− decisionTree =

284− Cases.compile (error "need a VariantDict") patterns

285−

286− branches =

287− Map.fromList indexedBranches

288− in

289− Opt.Case

290− <$> justConvert expr

291− <*> pure decisionTree

292− <*> T.traverse keepLooking branches

277+ Expr.Case expr branches ->

278+ optimizeCase context region expr branches

293279

294280 Expr.Data name exprs ->

295281 Opt.Data name <$> T.traverse justConvert exprs

@@ -394,6 +380,115 @@ freshName =

394380 return ("_p" ++ show uid)

395381

396382

383+-- OPTIMIZE CASES

384+

385+optimizeCase

386+ :: Context

387+ -> R.Region

388+ -> Can.Expr

389+ -> [(P.CanonicalPattern, Can.Expr)]

390+ -> Optimizer Opt.Expr

391+optimizeCase context region expr rawBranches =

392+ let

393+ indexify index (pattern, branch) =

394+ ( (pattern, index)

395+ , (index, branch)

396+ )

397+ in

398+ do optBranches <- T.traverse (mapSnd (optimizeExpr context)) rawBranches

399+ crashBranches <-

400+ case last optBranches of

401+ (A.A ann P.Anything, Opt.Call (Opt.Crash _ _) [arg]) ->

402+ do name <- freshName

403+ let newPattern = A.A ann (P.Var name)

404+ let newCall = Opt.Call (Opt.Crash region (Just name)) [arg]

405+ return (init optBranches ++ [(newPattern, newCall)])

406+

407+ _ ->

408+ return optBranches

409+

410+ let (patterns, indexedBranches) =

411+ unzip (zipWith indexify [0..] crashBranches)

412+

413+ let decisionTree =

414+ Cases.compile (error "need a VariantDict") patterns

415+

416+ optExpr <- optimizeExpr Nothing expr

417+

418+ return (inlinedCase optExpr decisionTree indexedBranches)

419+

420+

421+inlinedCase

422+ :: Opt.Expr

423+ -> Cases.DecisionTree Cases.Jump

424+ -> [(Int, Opt.Expr)]

425+ -> Opt.Expr

426+inlinedCase expr decisionTree jumpTargets =

427+ let

428+ substitutionDict =

429+ gatherSubstitutions decisionTree

430+

431+ (jumps, sharedBranches) =

432+ unzip (map (toJumps substitutionDict) jumpTargets)

433+ in

434+ Opt.Case

435+ expr

436+ (inlineJumps (Map.fromList jumps) decisionTree)

437+ (Maybe.catMaybes sharedBranches)

438+

439+

440+gatherSubstitutions

441+ :: Cases.DecisionTree Cases.Jump

442+ -> Map.Map Int [[(String, Cases.Path)]]

443+gatherSubstitutions decisionTree =

444+ case decisionTree of

445+ Cases.Decision _ edges fallback ->

446+ map snd edges

447+ |> maybe id (:) fallback

448+ |> map gatherSubstitutions

449+ |> Map.unionsWith (++)

450+

451+ Cases.Match (Cases.Jump target substitutions) ->

452+ Map.singleton target [substitutions]

453+

454+

455+toJumps

456+ :: Map.Map Int [[(String, Cases.Path)]]

457+ -> (Int, Opt.Expr)

458+ -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )

459+toJumps substitutionDict (target, branch) =

460+ case substitutionDict ! target of

461+ [substitutions] ->

462+ ( (target, Opt.Inline (Opt.Branch substitutions branch))

463+ , Nothing

464+ )

465+

466+ substitutions : _ ->

467+ ( (target, Opt.Jump target)

468+ , Just (target, Opt.Branch substitutions branch)

469+ )

470+

471+ _ ->

472+ error "it is not possible for there to be no substitutions"

473+

474+

475+inlineJumps

476+ :: Map.Map Int Opt.Jump

477+ -> Cases.DecisionTree Cases.Jump

478+ -> Cases.DecisionTree Opt.Jump

479+inlineJumps jumpDict decisionTree =

480+ let

481+ go =

482+ inlineJumps jumpDict

483+ in

484+ case decisionTree of

485+ Cases.Decision test edges fallback ->

486+ Cases.Decision test (map (second go) edges) (fmap go fallback)

487+

488+ Cases.Match (Cases.Jump target _) ->

489+ Cases.Match (jumpDict ! target)

490+

491+

397492-- OPTIMIZE BINOPS

398493

399494optimizeBinop

src/Optimize/Cases.hs+13−11

@@ -38,7 +38,7 @@ If 2 or more leaves point to the same label, we need to do some tricks in JS to

3838make that work nicely. When is JS getting goto?! ;) That is outside the scope

3939of this module though.

4040-}

41−compile :: VariantDict -> [(CPattern, Int)] -> DecisionTree Int

41+compile :: VariantDict -> [(CPattern, Int)] -> DecisionTree Jump

4242compile variantDict rawBranches =

4343 let

4444 format (pattern, index) =

@@ -67,15 +67,18 @@ type VariantDict =

6767-- DECISION TREES

6868

6969data DecisionTree a

70− = Decision

70+ = Match a

71+ | Decision

7172 { _test :: Path

7273 , _edges :: [(Test, DecisionTree a)]

7374 , _default :: Maybe (DecisionTree a)

7475 }

75− | Match

76− { _result :: a

77− , _substitutions :: Map.Map String Path

78− }

76+

77+

78+data Jump = Jump

79+ { _result :: Int

80+ , _substitutions :: [(String, Path)]

81+ }

7982

8083

8184data Test

@@ -127,7 +130,7 @@ data Branch =

127130 }

128131

129132

130−toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Int

133+toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Jump

131134toDecisionTree variantDict rawBranches =

132135 let

133136 branches =

@@ -135,7 +138,7 @@ toDecisionTree variantDict rawBranches =

135138 in

136139 case checkForMatch branches of

137140 Just (goal, substitutions) ->

138− Match goal substitutions

141+ Match (Jump goal substitutions)

139142

140143 Nothing ->

141144 let

@@ -232,12 +235,11 @@ path. If that is the case we give the resulting label and a mapping from free

232235variables to "how to get their value". So a pattern like (Just (x,_)) will give

233236us something like ("x" => value.0.0)

234237-}

235−checkForMatch :: [Branch] -> Maybe (Int, Map.Map String Path)

238+checkForMatch :: [Branch] -> Maybe (Int, [(String, Path)])

236239checkForMatch branches =

237240 case branches of

238241 Branch goal patterns : _ ->

239− do subs <- concat `fmap` mapM getSubstitution patterns

240− return (goal, Map.fromList subs)

242+ (,) goal `fmap` concat `fmap` mapM getSubstitution patterns

241243

242244 _ ->

243245 Nothing