f4a182c · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Put inlined version of Case into optimized AST

f4a182cEvan Czaplicki11 years ago

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

compare with master

unifiedsplit

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

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Optimized

3− ( Expr(..)

4− , Def(..)

5− , Facts(..)

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

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

6 ) where

5 ) where

8−import qualified Data.Map as Map

9−

10import qualified AST.Expression.General as General

7import qualified AST.Expression.General as General

11import qualified AST.Literal as Literal

8import qualified AST.Literal as Literal

12import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

13import qualified AST.Type as Type

10import qualified AST.Type as Type

14import qualified AST.Variable as Var

11import qualified AST.Variable as Var

15import qualified Optimize.Cases as PM

12import 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+ }

30+-- EXPRESSIONS

31+

18data Expr

32data Expr

19 = Literal Literal.Literal

33 = Literal Literal.Literal

20 | Var Var.Canonical

34 | Var Var.Canonical

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

26 | TailCall String [String] [Expr]

40 | TailCall String [String] [Expr]

27 | If [(Expr, Expr)] Expr

41 | If [(Expr, Expr)] Expr

28 | Let [Def] Expr

42 | Let [Def] Expr

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

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

30 | Data String [Expr]

44 | Data String [Expr]

31 | DataAccess Expr Int

45 | DataAccess Expr Int

32 | Access Expr String

46 | Access Expr String

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

34 | Record [(String, Expr)]

48 | Record [(String, Expr)]

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

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

36 | GLShader String String Literal.GLShaderTipe

50 | GLShader String String Literal.GLShaderTipe

37− | Crash

51+ | Crash R.Region (Maybe String)

40−data Def

54+data Jump

41− = Def Facts String Expr

55+ = Inline Branch

42− | TailDef Facts String [String] Expr

56+ | Jump Int

45−data Facts = Facts

59+data Branch = Branch

46− { home :: Maybe ModuleName.Canonical

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

47− , dependencies :: [Var.TopLevel]

61+ , _branch :: Expr

48− }

62+ }

src/Generate/JavaScript.hs+4−4

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

230 do expr' <- generateJsExpr expr

231 jsExpr (Port.task name expr' portType)

232

233− Crash ->

233+ Crash _ _ ->

234 error "TODO"

235

236

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

330

331generateCase

332 :: Opt.Expr

333− -> PM.DecisionTree Int

333+ -> PM.DecisionTree Opt.Jump

334− -> Map.Map Int Opt.Expr

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

335 -> State Int Code

336generateCase expr decisionTree branches =

337− error "TODO" expr decisionTree branches

337+ error "TODO"

338

339

340-- BINARY OPERATORS

src/Optimize.hs+115−20

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

1module Optimize (optimize) where

3import Control.Applicative

4+import Control.Arrow (second)

4import qualified Control.Monad as M

5import qualified Control.Monad as M

5import qualified Control.Monad.State as State

6import qualified Control.Monad.State as State

6import qualified Data.Map as Map

7import qualified Data.Map as Map

8+import Data.Map ((!))

9+import qualified Data.Maybe as Maybe

7import qualified Data.Traversable as T

10import qualified Data.Traversable as T

9import qualified AST.Expression.General as Expr

12import qualified AST.Expression.General as Expr

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

13import qualified AST.Module.Name as ModuleName

16import qualified AST.Module.Name as ModuleName

14import qualified AST.Pattern as P

17import qualified AST.Pattern as P

15import qualified AST.Variable as Var

18import qualified AST.Variable as Var

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

16import qualified Optimize.Cases as Cases

20import qualified Optimize.Cases as Cases

17import qualified Reporting.Annotation as A

21import qualified Reporting.Annotation as A

18import qualified Reporting.Region as R

22import qualified Reporting.Region as R

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

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

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

271 Opt.Let optDefs <$> keepLooking body

275 Opt.Let optDefs <$> keepLooking body

272

276

273− Expr.Case expr rawBranches ->

277+ Expr.Case expr branches ->

274− let

278+ optimizeCase context region expr branches

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

293

279

294 Expr.Data name exprs ->

280 Expr.Data name exprs ->

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

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

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

394 return ("_p" ++ show uid)

380 return ("_p" ++ show uid)

395

381

396

382

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+

397-- OPTIMIZE BINOPS

492-- OPTIMIZE BINOPS

398

493

399optimizeBinop

494optimizeBinop

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

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

39of this module though.

40-}

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

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

42compile variantDict rawBranches =

43 let

44 format (pattern, index) =

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

67-- DECISION TREES

69data DecisionTree a

70+ = Match a

70− = Decision

71+ | Decision

71 { _test :: Path

72 { _test :: Path

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

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

73 , _default :: Maybe (DecisionTree a)

74 , _default :: Maybe (DecisionTree a)

74 }

75 }

75− | Match

76+

77+

78+data Jump = Jump

76− { _result :: a

79+ { _result :: Int

77− , _substitutions :: Map.Map String Path

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

78− }

81+ }

81data Test

84data Test

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

127 }

130 }

128

131

129

132

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

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

131toDecisionTree variantDict rawBranches =

134toDecisionTree variantDict rawBranches =

132 let

135 let

133 branches =

136 branches =

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

135 in

138 in

136 case checkForMatch branches of

139 case checkForMatch branches of

137 Just (goal, substitutions) ->

140 Just (goal, substitutions) ->

138− Match goal substitutions

141+ Match (Jump goal substitutions)

139

142

140 Nothing ->

143 Nothing ->

141 let

144 let

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

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

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

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

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

234-}

237-}

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

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

236checkForMatch branches =

239checkForMatch branches =

237 case branches of

240 case branches of

238 Branch goal patterns : _ ->

241 Branch goal patterns : _ ->

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

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

240− return (goal, Map.fromList subs)

241

243

242 _ ->

244 _ ->

243 Nothing

245 Nothing