8ac06ce · elk · git.iko.soy

src/AST/Expression/General.hs+1−1

compare with master

unifiedsplit

@@ -67,7 +67,7 @@ data PortImpl expr tipe

67 = In String (Type.Port tipe)

68 | Out String expr (Type.Port tipe)

69 | Task String expr (Type.Port tipe)

70− deriving (Show)

70+ deriving (Eq, Show)

71

72

73portName :: PortImpl expr tipe -> String

src/AST/Expression/Optimized.hs+6−1

@@ -19,12 +19,14 @@ import qualified Reporting.Region as R

19data Def

20 = Def Facts String Expr

21 | TailDef Facts String [String] Expr

22+ deriving (Eq)

22

23

24

24data Facts = Facts

25data Facts = Facts

25 { home :: Maybe ModuleName.Canonical

26 { home :: Maybe ModuleName.Canonical

26 , dependencies :: [Var.TopLevel]

27 , dependencies :: [Var.TopLevel]

27 }

28 }

29+ deriving (Eq)

28

30

29

31

30dummyFacts :: Facts

32dummyFacts :: Facts

@@ -54,14 +56,17 @@ data Expr

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

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

55 | GLShader String String Literal.GLShaderTipe

57 | GLShader String String Literal.GLShaderTipe

56 | Crash R.Region (Maybe String)

58 | Crash R.Region (Maybe String)

59+ deriving (Eq)

57

60

58

61

59data Jump

62data Jump

60 = Inline Branch

63 = Inline Branch

61 | Jump Int

64 | Jump Int

65+ deriving (Eq)

62

66

63

67

64data Branch = Branch

68data Branch = Branch

65 { _substitutions :: [(String, DT.Path)]

69 { _substitutions :: [(String, DT.Path)]

66 , _branch :: Expr

70 , _branch :: Expr

67− }

71+ }

72+ deriving (Eq)

src/AST/Literal.hs+2−2

@@ -39,7 +39,7 @@ data GLTipe

39 | V4

40 | M4

41 | Texture

42− deriving (Show)

42+ deriving (Eq, Show)

43

44

45glTipeName :: GLTipe -> String

@@ -59,4 +59,4 @@ data GLShaderTipe = GLShaderTipe

59 , uniform :: Map.Map String GLTipe

60 , varying :: Map.Map String GLTipe

61 }

62− deriving (Show)

62+ deriving (Eq, Show)

src/AST/Type.hs+1−1

@@ -56,7 +56,7 @@ data Aliased t

56data Port t

57 = Normal t

58 | Signal { root :: t, arg :: t }

59− deriving (Show)

59+ deriving (Eq, Show)

60

61

62getPortType :: Port tipe -> tipe

src/Generate/JavaScript.hs+48−15

@@ -371,28 +371,59 @@ generateDecisionTree root decisionTree =

371 DT.Match (Opt.Jump target) ->

372 return [ BreakStmt () (Just (targetLabel root target)) ]

373

374− DT.Decision testPath edges fallback ->

374+ DT.Decision testPath [(test, subTree)] (Just fallback) ->

375− do accessExpr <- generateJsExpr (pathToExpr root testPath)

375+ let

376−

376+ (tests, deepestSubTree) =

377− let testExpr =

377+ collapseTests [(testPath, test)] fallback subTree

378− case fst (head edges) of

378+

379− DT.Constructor _ ->

379+ makeTest (path, test) =

380− DotRef () accessExpr (Id () "ctor")

380+ do testExpr <- pathToTestableExpr root path test

381−

381+ return (InfixExpr () OpStrictEq testExpr (testToExpr test))

382− DT.Literal _ ->

382+ in

383− accessExpr

383+ do testExprs <- mapM makeTest tests

384+ let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs

385+ thenBranch <- generateDecisionTree root deepestSubTree

386+ elseBranch <- generateDecisionTree root fallback

387+ return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]

384

388

389+ DT.Decision testPath edges fallback ->

390+ do testExpr <- pathToTestableExpr root testPath (fst (head edges))

385 caseClauses <- mapM (edgeToCaseClause root) edges

391 caseClauses <- mapM (edgeToCaseClause root) edges

386 caseDefault <- fallbackToDefault root fallback

392 caseDefault <- fallbackToDefault root fallback

387−

388 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]

393 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]

389

394

390

395

396+collapseTests

397+ :: [(DT.Path, DT.Test)]

398+ -> DT.DecisionTree Opt.Jump

399+ -> DT.DecisionTree Opt.Jump

400+ -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)

401+collapseTests tests outerFallback decisionTree =

402+ case decisionTree of

403+ DT.Decision testPath [(test, subTree)] (Just fallback)

404+ | fallback == outerFallback ->

405+ collapseTests ((testPath, test) : tests) outerFallback subTree

406+

407+ _ ->

408+ (tests, decisionTree)

409+

410+

391edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())

411edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())

392edgeToCaseClause root (test, subTree) =

412edgeToCaseClause root (test, subTree) =

393 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree

413 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree

394

414

395

415

416+pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())

417+pathToTestableExpr root path exampleTest =

418+ do accessExpr <- generateJsExpr (pathToExpr root path)

419+ case exampleTest of

420+ DT.Constructor _ ->

421+ return (DotRef () accessExpr (Id () "ctor"))

422+

423+ DT.Literal _ ->

424+ return accessExpr

425+

426+

396testToExpr :: DT.Test -> Expression ()

427testToExpr :: DT.Test -> Expression ()

397testToExpr test =

428testToExpr test =

398 case test of

429 case test of

@@ -419,15 +450,17 @@ fallbackToDefault root fallback =

419

450

420generateBranch :: String -> Opt.Branch -> State Int [Statement ()]

451generateBranch :: String -> Opt.Branch -> State Int [Statement ()]

421generateBranch root (Opt.Branch substitutions expr) =

452generateBranch root (Opt.Branch substitutions expr) =

422− do subts <- mapM (loadPath root) substitutions

453+ do substs <- mapM (loadPath root) substitutions

454+ let substStmts =

455+ if null substs then [] else [ VarDeclStmt () substs ]

423 code <- generateCode expr

456 code <- generateCode expr

424− return (subts ++ toStatementList code)

457+ return (substStmts ++ toStatementList code)

425

458

426

459

427−loadPath :: String -> (String, DT.Path) -> State Int (Statement ())

460+loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())

428loadPath root (name, path) =

461loadPath root (name, path) =

429 do jsAccessExpr <- generateJsExpr (pathToExpr root path)

462 do jsAccessExpr <- generateJsExpr (pathToExpr root path)

430− return $ VarDeclStmt () [ varDecl name jsAccessExpr ]

463+ return $ varDecl name jsAccessExpr

431

464

432

465

433pathToExpr :: String -> DT.Path -> Opt.Expr

466pathToExpr :: String -> DT.Path -> Opt.Expr

src/Optimize/Patterns/DecisionTree.hs+75−31

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

12-}

13

14import Control.Arrow (second)

15−import Data.Function (on)

16import qualified Data.List as List

15import qualified Data.List as List

17import qualified Data.Map as Map

16import qualified Data.Map as Map

18import qualified Data.Set as Set

17import qualified Data.Set as Set

@@ -74,6 +73,7 @@ data DecisionTree a

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

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

75 , _default :: Maybe (DecisionTree a)

74 , _default :: Maybe (DecisionTree a)

76 }

75 }

76+ deriving (Eq)

77

78

79data Jump = Jump

@@ -144,37 +144,23 @@ toDecisionTree variantDict rawBranches =

144 Nothing ->

145 let

146 path =

147− smallDefaults branches

147+ pickPath variantDict branches

148−

149− relevantTests =

150− testsAtPath path branches

151−

152− allRawEdges =

153− map (edgesFor path branches) relevantTests

154−

155− (rawEdges, unexplored) =

156− if isComplete variantDict relevantTests then

157− ( init allRawEdges

158− , snd (last allRawEdges)

159− )

160

148

161− else

149+ (edges, fallback) =

162− ( allRawEdges

150+ gatherEdges variantDict branches path

163− , filter (isIrrelevantTo path) branches

164− )

165

151

166− edges =

152+ decisionEdges =

167− map (second (toDecisionTree variantDict)) rawEdges

153+ map (second (toDecisionTree variantDict)) edges

168 in

154 in

169− case (edges, unexplored) of

155+ case (decisionEdges, fallback) of

170 ([(_tag, decisionTree)], []) ->

156 ([(_tag, decisionTree)], []) ->

171 decisionTree

157 decisionTree

172

158

173 (_, []) ->

159 (_, []) ->

174− Decision path edges Nothing

160+ Decision path decisionEdges Nothing

175

161

176 (_, _) ->

162 (_, _) ->

177− Decision path edges (Just (toDecisionTree variantDict unexplored))

163+ Decision path decisionEdges (Just (toDecisionTree variantDict fallback))

178

164

179

165

180isComplete :: VariantDict -> [Test] -> Bool

166isComplete :: VariantDict -> [Test] -> Bool

@@ -283,6 +269,28 @@ getSubstitution (path, A.A _ pattern) =

283 Nothing

269 Nothing

284

270

285

271

272+-- GATHER OUTGOING EDGES

273+

274+gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])

275+gatherEdges variantDict branches path =

276+ let

277+ relevantTests =

278+ testsAtPath path branches

279+

280+ allRawEdges =

281+ map (edgesFor path branches) relevantTests

282+ in

283+ if isComplete variantDict relevantTests then

284+ ( init allRawEdges

285+ , snd (last allRawEdges)

286+ )

287+

288+ else

289+ ( allRawEdges

290+ , filter (isIrrelevantTo path) branches

291+ )

292+

293+

286-- FIND RELEVANT TESTS

294-- FIND RELEVANT TESTS

287

295

288testsAtPath :: Path -> [Branch] -> [Test]

296testsAtPath :: Path -> [Branch] -> [Test]

@@ -420,18 +428,20 @@ needsTests (A.A _ pattern) =

420 True

428 True

421

429

422

430

423−-- PATH PICKING HEURISTICS

431+-- PICK A PATH

424

432

425−smallDefaults :: [Branch] -> Path

433+pickPath :: VariantDict -> [Branch] -> Path

426−smallDefaults branches =

434+pickPath variantDict branches =

427 let

435 let

428 allPaths =

436 allPaths =

429 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)

437 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)

430−

431− weightedPaths =

432− map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths

433 in

438 in

434− fst (List.minimumBy (compare `on` snd) weightedPaths)

439+ case bests (addWeights (smallDefaults branches) allPaths) of

440+ [path] ->

441+ path

442+

443+ tiedPaths ->

444+ head (bests (addWeights (smallBranchingFactor variantDict branches) tiedPaths))

435

445

436

446

437isChoicePath :: (Path, CPattern) -> Maybe Path

447isChoicePath :: (Path, CPattern) -> Maybe Path

@@ -442,4 +452,38 @@ isChoicePath (path, pattern) =

442 Nothing

452 Nothing

443

453

444

454

455+addWeights :: (Path -> Int) -> [Path] -> [(Path, Int)]

456+addWeights toWeight paths =

457+ map (\path -> (path, toWeight path)) paths

458+

459+

460+bests :: [(Path, Int)] -> [Path]

461+bests ((path,weight):weightedPaths) =

462+ let

463+ gatherMinimum acc@(minWeight, paths) (path, weight) =

464+ if weight == minWeight then

465+ (minWeight, path : paths)

466+

467+ else if weight < minWeight then

468+ (weight, [path])

469+

470+ else

471+ acc

472+ in

473+ snd (List.foldl' gatherMinimum (weight, [path]) weightedPaths)

474+

475+

476+-- PATH PICKING HEURISTICS

477+

478+smallDefaults :: [Branch] -> Path -> Int

479+smallDefaults branches path =

480+ length (filter (isIrrelevantTo path) branches)

481+

482+

445−-- smallBranchingFactor :: [Branch] -> Path

483+smallBranchingFactor :: VariantDict -> [Branch] -> Path -> Int

484+smallBranchingFactor variantDict branches path =

485+ let

486+ (edges, fallback) =

487+ gatherEdges variantDict branches path

488+ in

489+ length edges + (if null fallback then 0 else 1)

src/Optimize/Substitute.hsdeleted−103

@@ -1,103 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Optimize.Substitute (subst) where

3−

4−import Control.Arrow (second, (***))

5−

6−import AST.Expression.General (Expr'(..), PortImpl(..))

7−import qualified AST.Expression.Optimized as Optimized

8−import qualified AST.Pattern as Pattern

9−import qualified AST.Variable as V

10−import Elm.Utils ((|>))

11−import qualified Reporting.Annotation as A

12−

13−

14−subst :: String -> Optimized.Expr' -> Optimized.Expr' -> Optimized.Expr'

15−subst old new expression =

16− let f (A.A a e) = A.A a (subst old new e) in

17− case expression of

18− Range lo hi ->

19− Range (f lo) (f hi)

20−

21− ExplicitList exprs ->

22− ExplicitList (map f exprs)

23−

24− Binop op left right ->

25− Binop op (f left) (f right)

26−

27− Lambda pattern body ->

28− if Pattern.member old pattern

29− then expression

30− else Lambda pattern (f body)

31−

32− App func arg ->

33− App (f func) (f arg)

34−

35− If branches finally ->

36− If (map (f *** f) branches) (f finally)

37−

38− Let defs body ->

39− if anyShadow

40− then expression

41− else Let (map substDef defs) (f body)

42− where

43− substDef (Optimized.Definition facts pattern expr) =

44− Optimized.Definition facts pattern (f expr)

45−

46− anyShadow =

47− map (\(Optimized.Definition _ p _) -> p) defs

48− |> any (Pattern.member old)

49−

50− Var (V.Canonical home x) ->

51− case home of

52− V.Module _ ->

53− expression

54−

55− V.BuiltIn ->

56− expression

57−

58− V.Local ->

59− if x == old then new else expression

60−

61− V.TopLevel _ ->

62− if x == old then new else expression

63−

64− Case e cases ->

65− Case (f e) (map substCase cases)

66− where

67− substCase (pattern, expr) =

68− if Pattern.member old pattern

69− then (pattern, expr)

70− else (pattern, f expr)

71−

72− Data tag values ->

73− Data tag (map f values)

74−

75− Access record field ->

76− Access (f record) field

77−

78− Update record fields ->

79− Update (f record) (map (second f) fields)

80−

81− Record fields ->

82− Record (map (second f) fields)

83−

84− Literal _ ->

85− expression

86−

87− GLShader _ _ _ ->

88− expression

89−

90− Port impl ->

91− Port $

92− case impl of

93− In _ _ ->

94− impl

95−

96− Out name expr tipe ->

97− Out name (f expr) tipe

98−

99− Task name expr tipe ->

100− Task name (f expr) tipe

101−

102− Crash _ ->

103− expression

src/Reporting/Region.hs+2−2

@@ -10,14 +10,14 @@ data Region = Region

10 { start :: Position

11 , end :: Position

12 }

13− deriving (Show)

13+ deriving (Eq, Show)

14

15

16data Position = Position

17 { line :: Int

18 , column :: Int

19 }

20− deriving (Show)

20+ deriving (Eq, Show)

21

22

23fromSourcePos :: Parsec.SourcePos -> Position

tests/test-files/good-expected-js/CaseExpression3.elm.js+15−11

@@ -9,15 +9,19 @@ list2) {

9 var _p0 = {ctor: "_Tuple2"

10 ,_0: list1

11 ,_1: list2};

12− switch (_p0._0.ctor)

12+ if (_p0._0.ctor === "Nil") {

13− {case "Nil": return elm_lang$core$Main$Nil;

13+ return elm_lang$core$Main$Nil;

14+ } else {

14− default: switch (_p0._1.ctor)

15+ if (_p0._1.ctor === "Nil") {

15− {case "Nil": return elm_lang$core$Main$Nil;

16+ return elm_lang$core$Main$Nil;

17+ } else {

16− default: var x = _p0._0._0;

18+ var x = _p0._0._0,

17− var xs = _p0._0._1;

19+ xs = _p0._0._1,

18− var y = _p0._1._0;

20+ y = _p0._1._0,

19− var ys = _p0._1._1;

21+ ys = _p0._1._1;

20− return A2(elm_lang$core$Main$Cons,

22+ return A2(elm_lang$core$Main$Cons,

21− {ctor: "_Tuple2",_0: x,_1: y},

23+ {ctor: "_Tuple2",_0: x,_1: y},

22− A2(elm_lang$core$Main$zip,xs,ys));}}

24+ A2(elm_lang$core$Main$zip,xs,ys));

25+ }

26+ }

23});

27});

tests/test-files/good-expected-js/TailRecursive.elm.js+11−10

@@ -2,15 +2,16 @@ var elm_lang$core$Main$_op = {};

2var elm_lang$core$Main$any = F2(function (f,l) {

3 any: while (true) {

4 var _p0 = l;

5− switch (_p0.ctor)

5+ if (_p0.ctor === "::") {

6− {case "::": var x = _p0._0;

6+ var x = _p0._0,xs = _p0._1;

7− var xs = _p0._1;

8− if (f(x)) return true; else {

7+ if (f(x)) return true; else {

9− var _v0 = f,_v1 = xs;

8+ var _v0 = f,_v1 = xs;

10− f = _v0;

9+ f = _v0;

11− l = _v1;

10+ l = _v1;

12− continue any;

11+ continue any;

13− }

12+ }

13+ } else {

14− default: return false;}

14+ return false;

15+ }

15 }

16 }

16});

17});