b1b8b2e · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Merge pull request #1118 from elm-lang/dev

b1b8b2eEvan Czaplicki11 years ago

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

compare with master

unifiedsplit

@@ -54,7 +54,7 @@ data Expr

54 | Record [(String, Expr)]

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

56 | GLShader String String Literal.GLShaderTipe

57− | Crash R.Region (Maybe String)

57+ | Crash ModuleName.Canonical R.Region (Maybe Expr)

60data Decider a

src/Elm/Compiler/Imports.hs+1

@@ -13,6 +13,7 @@ import qualified AST.Variable as Var

13defaults :: [Module.DefaultImport]

14defaults =

15 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing

16+ , ["Debug"] ==> Module.ImportMethod Nothing Var.closedListing

16 , ["List"] ==> exposing [Var.Value "::"]

17 , ["List"] ==> exposing [Var.Value "::"]

17 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]

18 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]

18 , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]

19 , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]

src/Generate/JavaScript/BuiltIn.hs+20−4

@@ -3,17 +3,21 @@ module Generate.JavaScript.BuiltIn where

3import Control.Arrow (first)

4import qualified Language.ECMAScript3.Syntax as JS

6+import qualified AST.Module.Name as ModuleName

6import Generate.JavaScript.Helpers

7import Generate.JavaScript.Helpers

7import qualified Reporting.Region as R

8import qualified Reporting.Region as R

11+

10utils :: String -> [JS.Expression ()] -> JS.Expression ()

12utils :: String -> [JS.Expression ()] -> JS.Expression ()

11utils func args =

13utils func args =

12 obj ["_U", func] `call` args

14 obj ["_U", func] `call` args

17+

15-- LITERALS

18-- LITERALS

20+

17character :: Char -> JS.Expression ()

21character :: Char -> JS.Expression ()

18character char =

22character char =

19 utils "chr" [ JS.StringLit () [char] ]

23 utils "chr" [ JS.StringLit () [char] ]

@@ -24,8 +28,10 @@ string str =

24 JS.StringLit () str

28 JS.StringLit () str

31+

27-- LISTS

32-- LISTS

34+

29list :: [JS.Expression ()] -> JS.Expression ()

35list :: [JS.Expression ()] -> JS.Expression ()

30list elements =

36list elements =

31 utils "list" [ JS.ArrayLit () elements ]

37 utils "list" [ JS.ArrayLit () elements ]

@@ -36,8 +42,10 @@ range low high =

36 utils "range" [ low, high ]

42 utils "range" [ low, high ]

45+

39-- RECORDS

46-- RECORDS

48+

41recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()

49recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()

42recordUpdate record fields =

50recordUpdate record fields =

43 utils "update"

51 utils "update"

@@ -46,8 +54,10 @@ recordUpdate record fields =

46 ]

54 ]

57+

49-- COMPARISIONS

58-- COMPARISIONS

60+

51eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()

61eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()

52eq left right =

62eq left right =

53 utils "eq" [ left, right ]

63 utils "eq" [ left, right ]

@@ -58,16 +68,22 @@ cmp left right =

58 utils "cmp" [ left, right ]

68 utils "cmp" [ left, right ]

71+

61-- CRASH

72-- CRASH

74+

63−crash :: R.Region -> Maybe String -> JS.Expression ()

75+crash :: ModuleName.Canonical -> R.Region -> Maybe (JS.Expression ()) -> JS.Expression ()

64−crash region maybeCaseCrashValue =

76+crash home region maybeCaseCrashValue =

77+ let

78+ homeString =

79+ JS.StringLit () (ModuleName.canonicalToString home)

80+ in

65 case maybeCaseCrashValue of

81 case maybeCaseCrashValue of

66 Nothing ->

82 Nothing ->

67− utils "crash" [ regionToJs region ]

83+ utils "crash" [ homeString, regionToJs region ]

69 Just crashValue ->

85 Just crashValue ->

70− utils "caseCrash" [ regionToJs region, ref crashValue ]

86+ utils "crashCase" [ homeString, regionToJs region, crashValue ]

73regionToJs :: R.Region -> JS.Expression ()

89regionToJs :: R.Region -> JS.Expression ()

src/Generate/JavaScript/Expression.hs+3−2

@@ -209,8 +209,9 @@ generateCode expr =

209 do expr' <- generateJsExpr expr

210 jsExpr (Port.task name expr' portType)

211

212− Crash region maybeCaseCrashValue ->

212+ Crash home region maybeBranchProblem ->

213+ do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem

213− jsExpr $ BuiltIn.crash region maybeCaseCrashValue

214+ jsExpr $ BuiltIn.crash home region maybeOptBranchProblem

214

215

216

216-- FUNCTIONS

217-- FUNCTIONS

src/Optimize.hs+83−38

@@ -19,8 +19,10 @@ import qualified Reporting.Annotation as A

19import qualified Reporting.Region as R

22+

22-- OPTIMIZE

23-- OPTIMIZE

25+

24optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized

26optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized

25optimize variantDict module_@(Module.Module home _ _ _ _ body) =

27optimize variantDict module_@(Module.Module home _ _ _ _ body) =

26 let

28 let

@@ -28,7 +30,7 @@ optimize variantDict module_@(Module.Module home _ _ _ _ body) =

28 flattenLets [] (Module.program body)

30 flattenLets [] (Module.program body)

30 optDefs =

32 optDefs =

31− Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

33+ Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)

32 in

34 in

33 module_ { Module.body = body { Module.program = optDefs } }

35 module_ { Module.body = body { Module.program = optDefs } }

@@ -43,56 +45,77 @@ flattenLets defs annExpr@(A.A _ expr) =

43 (defs, annExpr)

45 (defs, annExpr)

48+

46-- CONVERT DEFINITIONS

49-- CONVERT DEFINITIONS

51+

48−optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Env.Optimizer [Opt.Def]

52+optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]

49−optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =

53+optimizeDef isRoot (Can.Definition (Can.Facts deps) pattern expression _) =

50 let

54 let

51− (args, rawBody) =

55+ (args, canBody) =

52 Expr.collectLambdas expression

56 Expr.collectLambdas expression

53 in

57 in

54− case (ptrn, args) of

58+ do home <-

55− (P.Var name, _ : _) ->

59+ if isRoot then

60+ Just <$> Env.getHome

61+ else

62+ return Nothing

57− do htc <- Env.getTailCall

64+ optimizeDefHelp home deps pattern args canBody

58− Env.setTailCall False

60− (args, body) <- optimizeFunction (Just name) args rawBody

62− isTailCall <- Env.getTailCall

67+optimizeDefHelp

63− Env.setTailCall htc

68+ :: Maybe ModuleName.Canonical

69+ -> [Var.TopLevel]

70+ -> P.CanonicalPattern

71+ -> [P.CanonicalPattern]

72+ -> Can.Expr

73+ -> Env.Optimizer [Opt.Def]

74+optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =

75+ let

76+ facts =

77+ Opt.Facts home deps

78+ in

79+ case (ptrn, args) of

80+ (P.Var name, _ : _) ->

65− let facts = Opt.Facts home deps

82+ do htc <- Env.getTailCall

83+ Env.setTailCall False

67− return $

85+ (args, body) <- optimizeFunction (Just name) args rawBody

68− if isTailCall then

70− [ Opt.TailDef facts name args body ]

87+ isTailCall <- Env.getTailCall

88+ Env.setTailCall htc

72− else

90+ return $

91+ if isTailCall then

92+ [ Opt.TailDef facts name args body ]

94+ else

74 [ Opt.Def facts name (Opt.Function args body) ]

95 [ Opt.Def facts name (Opt.Function args body) ]

76− (P.Var name, []) ->

97+ (P.Var name, []) ->

78− do hasTailCall <- Env.getTailCall

99+ do hasTailCall <- Env.getTailCall

79− body <- optimizeExpr Nothing rawBody

100+ body <- optimizeExpr Nothing rawBody

80− Env.setTailCall hasTailCall

101+ Env.setTailCall hasTailCall

81− return [ Opt.Def (Opt.Facts home deps) name body ]

102+ return [ Opt.Def facts name body ]

103

83− (_, []) ->

104+ (_, []) ->

105

85− do name <- Env.freshName

106+ do name <- Env.freshName

86− optBody <- optimizeExpr Nothing rawBody

107+ optBody <- optimizeExpr Nothing rawBody

87− let optDef = Opt.Def (Opt.Facts home deps) name optBody

108+ let optDef = Opt.Def facts name optBody

88− return (optDef : patternToDefs home name pattern)

109+ return (optDef : patternToDefs home name pattern)

110+

111+ _ ->

112+ error "there should never be a function where the name is not a P.Var"

113

90− _ ->

91− error "there should never be a function where the name is not a P.Var"

114

115

94-- OPTIMIZE FUNCTION

116-- OPTIMIZE FUNCTION

117

118+

96optimizeFunction

119optimizeFunction

97 :: Maybe String

120 :: Maybe String

98 -> [P.CanonicalPattern]

121 -> [P.CanonicalPattern]

@@ -196,7 +219,8 @@ optimizeExpr context annExpr@(A.A region expression) =

196

219

197 Expr.Var name ->

220 Expr.Var name ->

198 if name == Var.inCore ["Debug"] "crash" then

221 if name == Var.inCore ["Debug"] "crash" then

222+ do home <- Env.getHome

199− pure (Opt.Crash region Nothing)

223+ pure (Opt.Crash home region Nothing)

200

224

201 else

225 else

202 pure (Opt.Var name)

226 pure (Opt.Var name)

@@ -248,7 +272,7 @@ optimizeExpr context annExpr@(A.A region expression) =

248 <*> keepLooking finally

272 <*> keepLooking finally

249

273

250 Expr.Let defs body ->

274 Expr.Let defs body ->

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

275+ do optDefs <- concat <$> T.traverse (optimizeDef False) defs

252 Opt.Let optDefs <$> keepLooking body

276 Opt.Let optDefs <$> keepLooking body

253

277

254 Expr.Case expr branches ->

278 Expr.Case expr branches ->

@@ -256,8 +280,8 @@ optimizeExpr context annExpr@(A.A region expression) =

256 variantDict <- Env.getVariantDict

280 variantDict <- Env.getVariantDict

257

281

258 name <- Env.freshName

282 name <- Env.freshName

259− optBranches <- T.traverse (optimizeBranch context name) branches

283+ optBranches <- T.traverse (optimizeBranch context region name) branches

260− optCase <- Case.optimize variantDict region name optBranches

284+ let optCase = Case.optimize variantDict name optBranches

261 return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase

285 return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase

262

286

263 Expr.Data name exprs ->

287 Expr.Data name exprs ->

@@ -302,19 +326,40 @@ mapSnd func (x, a) =

302

326

303optimizeBranch

327optimizeBranch

304 :: Context

328 :: Context

329+ -> R.Region

305 -> String

330 -> String

306 -> (P.CanonicalPattern, Can.Expr)

331 -> (P.CanonicalPattern, Can.Expr)

307 -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

332 -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

308−optimizeBranch context exprName (pattern, canonicalExpr) =

333+optimizeBranch context region exprName (rawPattern, canBranch) =

309 let

334 let

310 root =

335 root =

311 Opt.Var (Var.Canonical Var.Local exprName)

336 Opt.Var (Var.Canonical Var.Local exprName)

312−

313− substitutions =

314− Map.fromList (patternToSubstitutions root pattern)

315 in

337 in

316− do optExpr <- optimizeExpr context canonicalExpr

338+ do optBranch <- optimizeExpr context canBranch

339+ (pattern, branch) <- tagCrashBranch region rawPattern optBranch

340+

341+ let substitutions =

342+ Map.fromList (patternToSubstitutions root pattern)

343+

317− (,) pattern <$> Inline.inline substitutions optExpr

344+ (,) pattern <$> Inline.inline substitutions branch

345+

346+

347+tagCrashBranch

348+ :: R.Region

349+ -> P.CanonicalPattern

350+ -> Opt.Expr

351+ -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

352+tagCrashBranch region pattern@(A.A pr _) expr =

353+ case expr of

354+ Opt.Call (Opt.Crash home _ _) [arg] ->

355+ do name <- Env.freshName

356+ return

357+ ( A.A pr (P.Alias name pattern)

358+ , Opt.Call (Opt.Crash home region (Just (Opt.Var (Var.local name)))) [arg]

359+ )

360+

361+ _ ->

362+ return (pattern, expr)

318

363

319

364

320-- DETECT TAIL CALL

365-- DETECT TAIL CALL

src/Optimize/Case.hs+9−39

@@ -9,49 +9,22 @@ import qualified Data.Maybe as Maybe

9import qualified AST.Expression.Optimized as Opt

10import qualified AST.Pattern as P

11import qualified Optimize.DecisionTree as DT

12−import qualified Optimize.Environment as Env

13−import qualified Reporting.Annotation as A

14−import qualified Reporting.Region as R

18-- OPTIMIZE A CASE EXPRESSION

15-- OPTIMIZE A CASE EXPRESSION

21−optimize

22− :: DT.VariantDict

23− -> R.Region

24− -> String

25− -> [(P.CanonicalPattern, Opt.Expr)]

18+optimize :: DT.VariantDict -> String -> [(P.CanonicalPattern, Opt.Expr)] -> Opt.Expr

26− -> Env.Optimizer Opt.Expr

27−optimize variantDict region exprName optBranches =

19+optimize variantDict exprName optBranches =

28− do crashBranches <-

20+ let

29− mapM (tagCrashBranches region) optBranches

30−

31− let (patterns, indexedBranches) =

21+ (patterns, indexedBranches) =

32− unzip (zipWith indexify [0..] crashBranches)

22+ unzip (zipWith indexify [0..] optBranches)

33−

34− let decisionTree =

35− DT.compile variantDict patterns

36−

37− return (treeToExpr exprName decisionTree indexedBranches)

38−

39−

40−tagCrashBranches

41− :: R.Region

42− -> (P.CanonicalPattern, Opt.Expr)

43− -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

44−tagCrashBranches region branch@(pattern@(A.A pr _), expr) =

45− case expr of

46− Opt.Call (Opt.Crash _ _) [arg] ->

47− do name <- Env.freshName

48− return

49− ( A.A pr (P.Alias name pattern)

50− , Opt.Call (Opt.Crash region (Just name)) [arg]

51− )

53− _ ->

24+ decisionTree =

54− return branch

25+ DT.compile variantDict patterns

26+ in

27+ treeToExpr exprName decisionTree indexedBranches

57indexify :: Int -> (a,b) -> ((a,Int), (Int,b))

30indexify :: Int -> (a,b) -> ((a,Int), (Int,b))

@@ -198,6 +171,3 @@ insertChoices choiceDict decider =

198 Opt.FanOut path tests fallback ->

171 Opt.FanOut path tests fallback ->

199 Opt.FanOut path (map (second go) tests) (go fallback)

172 Opt.FanOut path (map (second go) tests) (go fallback)

200

173

201−

202−

203−

src/Optimize/Environment.hs+15−6

@@ -2,12 +2,14 @@ module Optimize.Environment

2 ( Optimizer, run

3 , Env

4 , getVariantDict

5+ , getHome

5 , getTailCall, setTailCall

6 , getTailCall, setTailCall

6 , freshName

7 , freshName

7 ) where

8 ) where

9import qualified Control.Monad.State as State

10import qualified Control.Monad.State as State

12+import qualified AST.Module.Name as ModuleName

11import qualified Optimize.DecisionTree as DT

13import qualified Optimize.DecisionTree as DT

@@ -15,15 +17,16 @@ type Optimizer a =

15 State.State Env a

17 State.State Env a

18−run :: DT.VariantDict -> Optimizer a -> a

20+run :: DT.VariantDict -> ModuleName.Canonical -> Optimizer a -> a

19−run variantDict optimizer =

21+run variantDict home optimizer =

20− State.evalState optimizer (Env False 0 variantDict)

22+ State.evalState optimizer (Env False 0 variantDict home)

23data Env = Env

25data Env = Env

24 { _hasTailCall :: Bool

26 { _hasTailCall :: Bool

25 , _uid :: Int

27 , _uid :: Int

26 , _variantDict :: DT.VariantDict

28 , _variantDict :: DT.VariantDict

29+ , _home :: ModuleName.Canonical

27 }

30 }

@@ -32,6 +35,11 @@ getVariantDict =

32 State.gets _variantDict

35 State.gets _variantDict

38+getHome :: Optimizer ModuleName.Canonical

39+getHome =

40+ State.gets _home

41+

42+

35getTailCall :: Optimizer Bool

43getTailCall :: Optimizer Bool

36getTailCall =

44getTailCall =

37 State.gets _hasTailCall

45 State.gets _hasTailCall

@@ -45,6 +53,7 @@ setTailCall bool =

46freshName :: Optimizer String

54freshName :: Optimizer String

47freshName =

55freshName =

48− do (Env htc uid vd) <- State.get

56+ do (Env htc uid vd home) <- State.get

49− State.put (Env htc (uid + 1) vd)

57+ State.put (Env htc (uid + 1) vd home)

50− return ("_p" ++ show uid)

58+ return ("_p" ++ show uid)

59+

src/Optimize/Inline.hs+7−4

@@ -13,6 +13,7 @@ import qualified AST.Variable as Var

13import qualified Optimize.Environment as Env

16+

16inline :: Map.Map String Opt.Expr -> Opt.Expr -> Env.Optimizer Opt.Expr

17inline :: Map.Map String Opt.Expr -> Opt.Expr -> Env.Optimizer Opt.Expr

17inline rawSubs expression =

18inline rawSubs expression =

18 let

19 let

@@ -178,12 +179,14 @@ count expression =

178 GLShader _ _ _ ->

179 GLShader _ _ _ ->

179 Map.empty

180 Map.empty

180

181

181− Crash _ _ ->

182+ Crash _ _ maybeBranchProblem ->

182− Map.empty

183+ maybe Map.empty count maybeBranchProblem

184+

183

185

184

186

185-- REPLACE

187-- REPLACE

186

188

189+

187replace :: Map.Map String Opt.Expr -> Opt.Expr -> Opt.Expr

190replace :: Map.Map String Opt.Expr -> Opt.Expr -> Opt.Expr

188replace substitutions expression =

191replace substitutions expression =

189 let

192 let

@@ -287,5 +290,5 @@ replace substitutions expression =

287 GLShader _ _ _ ->

290 GLShader _ _ _ ->

288 expression

291 expression

289

292

290− Crash _ _ ->

293+ Crash home region maybeBranchProblem ->

291− expression

294+ Crash home region (fmap go maybeBranchProblem)