3f6dcdb · elk · git.iko.soy

git.iko.soy/elk

Begin generating optimized pattern matches

commit3f6dcdbfeeca18691956dacf9aeb0619cae7f837 authorEvan Czaplicki <info@elm-lang.org> dateSun 6 Sep 2015, 01:11 (11 years ago) parenta6568b9

5 files changed+190−47

compare with master

unifiedsplit

src/AST/Expression/Optimized.hs+7−2 src/Generate/JavaScript.hs+114−9 src/Optimize.hs+26−16 src/Optimize/Environment.hs+29−5 src/Optimize/Patterns.hs+14−15

src/AST/Expression/Optimized.hs+7−2

@@ -1,6 +1,6 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Optimized

3− ( Def(..), Facts(..)

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

44 , Expr(..), Jump(..), Branch(..)

55 ) where

@@ -27,6 +27,11 @@ data Facts = Facts

2727 }

2828

2929

30+dummyFacts :: Facts

31+dummyFacts =

32+ Facts Nothing []

33+

34+

3035-- EXPRESSIONS

3136

3237data Expr

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

4045 | TailCall String [String] [Expr]

4146 | If [(Expr, Expr)] Expr

4247 | Let [Def] Expr

43− | Case Expr (DT.DecisionTree Jump) [(Int, Branch)]

48+ | Case String (DT.DecisionTree Jump) [(Int, Branch)]

4449 | Data String [Expr]

4550 | DataAccess Expr Int

4651 | Access Expr String

src/Generate/JavaScript.hs+114−9

@@ -11,7 +11,7 @@ import qualified Text.PrettyPrint.Leijen as PP

1111

1212import qualified AST.Expression.General as Expr

1313import AST.Expression.Optimized as Opt

14−import AST.Literal

14+import qualified AST.Literal as L

1515import qualified AST.Module as Module

1616import qualified AST.Module.Name as ModuleName

1717import qualified AST.Variable as Var

@@ -195,8 +195,8 @@ generateCode expr =

195195 If branches finally ->

196196 generateIf branches finally

197197

198− Case expr decisionTree branches ->

199− generateCase expr decisionTree branches

198+ Case root decisionTree branches ->

199+ JsBlock <$> generateCase root decisionTree branches

200200

201201 ExplicitList elements ->

202202 do jsElements <- mapM generateJsExpr elements

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

215215 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

216216

217217 GLShader _uid src _tipe ->

218− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]

218+ jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

219219

220220 Port impl ->

221221 case impl of

@@ -319,7 +319,7 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

319319 _ ->

320320 (reverse visitedBranches, finally)

321321

322− (Literal (Boolean True), branch) : _ ->

322+ (Literal (L.Boolean True), branch) : _ ->

323323 crushIfsHelp visitedBranches [] branch

324324

325325 visiting : unvisited ->

@@ -329,12 +329,117 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

329329-- CASE EXPRESSIONS

330330

331331generateCase

332− :: Opt.Expr

332+ :: String

333333 -> DT.DecisionTree Opt.Jump

334334 -> [(Int, Opt.Branch)]

335− -> State Int Code

336−generateCase expr decisionTree branches =

337− error "TODO"

335+ -> State Int [Statement ()]

336+generateCase root decisionTree jumpBranches =

337+ do decider <- generateDecisionTree root decisionTree

338+ foldM (goto root) decider jumpBranches

339+

340+

341+goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]

342+goto root decider (target, branch) =

343+ let

344+ deciderStmt =

345+ LabelledStmt ()

346+ (targetLabel root target)

347+ (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))

348+ in

349+ do stmts <- generateBranch root branch

350+ return (deciderStmt : stmts)

351+

352+

353+targetLabel :: String -> Int -> Id ()

354+targetLabel root target =

355+ Id () (root ++ "_" ++ show target)

356+

357+

358+generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]

359+generateDecisionTree root decisionTree =

360+ case decisionTree of

361+ DT.Match (Opt.Inline branch) ->

362+ generateBranch root branch

363+

364+ DT.Match (Opt.Jump target) ->

365+ return [ BreakStmt () (Just (targetLabel root target)) ]

366+

367+ DT.Decision testPath edges fallback ->

368+ do accessExpr <- generateJsExpr (pathToExpr root testPath)

369+

370+ let testExpr =

371+ case fst (head edges) of

372+ DT.Constructor _ ->

373+ DotRef () accessExpr (Id () "ctor")

374+

375+ DT.Literal _ ->

376+ accessExpr

377+

378+ caseClauses <- mapM (edgeToCaseClause root) edges

379+ caseDefault <- fallbackToDefault root fallback

380+

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

382+

383+

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

385+edgeToCaseClause root (test, subTree) =

386+ CaseClause () (testToExpr test) <$> generateDecisionTree root subTree

387+

388+

389+testToExpr :: DT.Test -> Expression ()

390+testToExpr test =

391+ case test of

392+ DT.Constructor (Var.Canonical _ tag) ->

393+ StringLit () tag

394+

395+ DT.Literal (L.Chr char) ->

396+ StringLit () [char]

397+

398+ DT.Literal lit ->

399+ Literal.literal lit

400+

401+

402+fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]

403+fallbackToDefault root fallback =

404+ case fallback of

405+ Nothing ->

406+ return []

407+

408+ Just subTree ->

409+ do stmts <- generateDecisionTree root subTree

410+ return [ CaseDefault () stmts ]

411+

412+

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

414+generateBranch root (Opt.Branch substitutions expr) =

415+ do subts <- mapM (loadPath root) substitutions

416+ code <- generateCode expr

417+ return (subts ++ toStatementList code)

418+

419+

420+loadPath :: String -> (String, DT.Path) -> State Int (Statement ())

421+loadPath root (name, path) =

422+ do jsAccessExpr <- generateJsExpr (pathToExpr root path)

423+ return $ VarDeclStmt () [ varDecl name jsAccessExpr ]

424+

425+

426+pathToExpr :: String -> DT.Path -> Opt.Expr

427+pathToExpr root fullPath =

428+ go (Opt.Var (Var.local root)) fullPath

429+ where

430+ go expr path =

431+ case path of

432+ DT.Position index subpath ->

433+ go (Opt.DataAccess expr index) subpath

434+

435+ DT.Field field subpath ->

436+ go (Opt.Access expr field) subpath

437+

438+ DT.Empty ->

439+ expr

440+

441+ DT.Alias ->

442+ expr

338443

339444

340445-- BINARY OPERATORS

src/Optimize.hs+26−16

@@ -2,7 +2,7 @@ module Optimize (optimize) where

33import Control.Applicative

44import qualified Control.Monad as M

5−import qualified Control.Monad.State as State

5+import qualified Data.Map as Map

66import qualified Data.Traversable as T

88import qualified AST.Expression.General as Expr

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

1212import qualified AST.Module.Name as ModuleName

1313import qualified AST.Pattern as P

1414import qualified AST.Variable as Var

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

1516import qualified Optimize.Environment as Env

1617import qualified Optimize.Patterns as Patterns

1718import qualified Reporting.Annotation as A

@@ -21,17 +22,25 @@ import qualified Reporting.Region as R

2122-- OPTIMIZE - turn a canonical module into a list of optimized defs

2223

2324optimize :: Module.CanonicalModule -> Module.Optimized

24−optimize module_ =

25+optimize (Module.Module home _ _ _ _ body) =

2526 let

26− home =

27− Module.name module_

28−

2927 (defs, _) =

30− flattenLets [] (Module.program (Module.body module_))

28+ flattenLets [] (Module.program body)

29+

30+ variantInfo (_, tags) =

31+ let

32+ variants = length tags

33+ in

34+ map (\(tag, _) -> (Var.fromModule home tag, variants)) tags

35+

36+ variantDict =

37+ Module.datatypes body

38+ |> Map.elems

39+ |> concatMap variantInfo

40+ |> Map.fromList

41+ |> Map.insert (Var.builtin "_Tuple2") 1

3142 in

32− State.evalState

33− (concat <$> mapM (optimizeDef (Just home)) defs)

34− (Env.Env False 0)

43+ Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

3544

3645

3746flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

@@ -55,13 +64,13 @@ optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expressio

5564 case (ptrn, args) of

5665 (P.Var name, _ : _) ->

5766

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

59− State.put (Env.Env False uid)

67+ do htc <- Env.getTailCall

68+ Env.setTailCall False

6069

6170 (args, body) <- optimizeFunction (Just name) args rawBody

6271

63− (Env.Env isTailCall uid') <- State.get

64− State.put (Env.Env htc uid')

72+ isTailCall <- Env.getTailCall

73+ Env.setTailCall htc

6574

6675 let facts = Opt.Facts home deps

6776

@@ -76,7 +85,7 @@ optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expressio

7685

7786 (P.Var name, []) ->

7887

79− do hasTailCall <- State.gets Env._hasTailCall

88+ do hasTailCall <- Env.getTailCall

8089 body <- optimizeExpr Nothing rawBody

8190 Env.setTailCall hasTailCall

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

@@ -231,7 +240,7 @@ optimizeExpr context annExpr@(A.A region expression) =

231240 return (Opt.TailCall name argNames optArgs)

232241

233242 Nothing ->

234− do hasTailCall <- State.gets Env._hasTailCall

243+ do hasTailCall <- Env.getTailCall

235244 optFunc <- justConvert func

236245 optArgs <- T.traverse justConvert args

237246 Env.setTailCall hasTailCall

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

253262 Expr.Case expr branches ->

254263 do optExpr <- optimizeExpr Nothing expr

255264 optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches

256− Patterns.optimize region optExpr optBranches

265+ variantDict <- Env.getVariantDict

266+ Patterns.optimize variantDict region optExpr optBranches

257267

258268 Expr.Data name exprs ->

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

src/Optimize/Environment.hs+29−5

@@ -1,26 +1,50 @@

1−module Optimize.Environment where

1+module Optimize.Environment

2+ ( Optimizer, run

3+ , Env

4+ , getVariantDict

5+ , getTailCall, setTailCall

6+ , freshName

7+ ) where

39import qualified Control.Monad.State as State

410

11+import qualified Optimize.Patterns.DecisionTree as DT

12+

513

614type Optimizer a =

715 State.State Env a

816

917

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

19+run variantDict optimizer =

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

21+

22+

1023data Env = Env

1124 { _hasTailCall :: Bool

1225 , _uid :: Int

26+ , _variantDict :: DT.VariantDict

1327 }

1428

1529

30+getVariantDict :: Optimizer DT.VariantDict

31+getVariantDict =

32+ State.gets _variantDict

33+

34+

35+getTailCall :: Optimizer Bool

36+getTailCall =

37+ State.gets _hasTailCall

38+

39+

1640setTailCall :: Bool -> Optimizer ()

1741setTailCall bool =

18− do uid <- State.gets _uid

19− State.put (Env bool uid)

42+ do env <- State.get

43+ State.put (env { _hasTailCall = bool })

2044

2145

2246freshName :: Optimizer String

2347freshName =

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

25− State.put (Env htc (uid + 1))

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

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

2650 return ("_p" ++ show uid)

src/Optimize/Patterns.hs+14−15

@@ -1,20 +1,13 @@

11{-# OPTIONS_GHC -Wall #-}

22module Optimize.Patterns (optimize) where

4−import Control.Applicative

54import Control.Arrow (second)

6−import qualified Control.Monad as M

7−import qualified Control.Monad.State as State

85import qualified Data.Map as Map

96import Data.Map ((!))

107import qualified Data.Maybe as Maybe

11−import qualified Data.Traversable as T

128

139import qualified AST.Expression.Optimized as Opt

14−import qualified AST.Module as Module

15−import qualified AST.Module.Name as ModuleName

1610import qualified AST.Pattern as P

17−import qualified AST.Variable as Var

1811import Elm.Utils ((|>))

1912import qualified Optimize.Environment as Env

2013import qualified Optimize.Patterns.DecisionTree as DT

@@ -23,11 +16,12 @@ import qualified Reporting.Region as R

2316

2417

2518optimize

26− :: R.Region

19+ :: DT.VariantDict

20+ -> R.Region

2721 -> Opt.Expr

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

2923 -> Env.Optimizer Opt.Expr

30−optimize region optExpr optBranches =

24+optimize variantDict region optExpr optBranches =

3125 let

3226 indexify index (pattern, branch) =

3327 ( (pattern, index)

@@ -49,17 +43,22 @@ optimize region optExpr optBranches =

4943 unzip (zipWith indexify [0..] crashBranches)

5044

5145 let decisionTree =

52− DT.compile (error "need a VariantDict") patterns

46+ DT.compile variantDict patterns

5347

54− return (inlinedCase optExpr decisionTree indexedBranches)

48+ tempName <- Env.freshName

49+

50+ return $

51+ Opt.Let

52+ [ Opt.Def Opt.dummyFacts tempName optExpr ]

53+ (inlinedCase tempName decisionTree indexedBranches)

5554

5655

5756inlinedCase

58− :: Opt.Expr

57+ :: String

5958 -> DT.DecisionTree DT.Jump

6059 -> [(Int, Opt.Expr)]

6160 -> Opt.Expr

62−inlinedCase expr decisionTree jumpTargets =

61+inlinedCase name decisionTree jumpTargets =

6362 let

6463 substitutionDict =

6564 gatherSubstitutions decisionTree

@@ -68,7 +67,7 @@ inlinedCase expr decisionTree jumpTargets =

6867 unzip (map (toJumps substitutionDict) jumpTargets)

6968 in

7069 Opt.Case

71− expr

70+ name

7271 (inlineJumps (Map.fromList jumps) decisionTree)

7372 (Maybe.catMaybes sharedBranches)

7473

@@ -122,4 +121,4 @@ inlineJumps jumpDict decisionTree =

122121 DT.Decision test (map (second go) edges) (fmap go fallback)

123122

124123 DT.Match (DT.Jump target _) ->

125− DT.Match (jumpDict ! target)

124+ DT.Match (jumpDict ! target)