5b4fbc7 · elk · git.iko.soy

git.iko.soy/elk

Upgrade Optimize code from String to Text

commit5b4fbc7705ea5aa9a2c31a6d17292d64996dc97d authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 5 Dec 2016, 21:33 (10 years ago) parenta672aa7

5 files changed+61−44

compare with master

unifiedsplit

src/Optimize.hs+33−25 src/Optimize/Case.hs+3−2 src/Optimize/DecisionTree.hs+9−7 src/Optimize/Environment.hs+6−2 src/Optimize/Inline.hs+10−8

src/Optimize.hs+33−25

@@ -1,8 +1,11 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

13module Optimize (optimize) where

35import qualified Control.Monad as M

46import qualified Data.Map as Map

57import qualified Data.Traversable as T

8+import Data.Text (Text)

710import qualified AST.Expression.Canonical as Can

811import qualified AST.Expression.Optimized as Opt

@@ -53,18 +56,18 @@ optimizeDefHelp

5356 -> [P.Canonical]

5457 -> Can.Expr

5558 -> Env.Optimizer [Opt.Def]

56−optimizeDefHelp home pattern@(A.A _ ptrn) args rawBody =

59+optimizeDefHelp home pattern@(A.A _ ptrn) rawArgs rawBody =

5760 let

5861 facts =

5962 Opt.Facts home

6063 in

61− case (ptrn, args) of

64+ case (ptrn, rawArgs) of

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

6366

6467 do htc <- Env.getTailCall

6568 Env.setTailCall False

6669

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

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

6871

6972 isTailCall <- Env.getTailCall

7073 Env.setTailCall htc

@@ -99,28 +102,28 @@ optimizeDefHelp home pattern@(A.A _ ptrn) args rawBody =

99102

100103

101104optimizeFunction

102− :: Maybe String

105+ :: Maybe Text

103106 -> [P.Canonical]

104107 -> Can.Expr

105− -> Env.Optimizer ([String], Opt.Expr)

108+ -> Env.Optimizer ([Text], Opt.Expr)

106109optimizeFunction maybeName patterns givenBody =

107110 do (argNames, body) <- M.foldM depatternArgs ([], givenBody) (reverse patterns)

108111 optBody <- optimizeExpr (makeContext argNames =<< maybeName) body

109112 return (argNames, optBody)

110113

111114

112−makeContext :: [String] -> String -> Context

115+makeContext :: [Text] -> Text -> Context

113116makeContext argNames name =

114117 Just (name, length argNames, argNames)

115118

116119

117−depatternArgs :: ([String], Can.Expr) -> P.Canonical -> Env.Optimizer ([String], Can.Expr)

120+depatternArgs :: ([Text], Can.Expr) -> P.Canonical -> Env.Optimizer ([Text], Can.Expr)

118121depatternArgs (names, rawExpr) ptrn =

119122 do (name, expr) <- depattern ptrn rawExpr

120123 return (name : names, expr)

121124

122125

123−patternToDefs :: Maybe ModuleName.Canonical -> String -> P.Canonical -> [Opt.Def]

126+patternToDefs :: Maybe ModuleName.Canonical -> Text -> P.Canonical -> [Opt.Def]

124127patternToDefs home rootName pattern =

125128 let

126129 rootExpr =

@@ -141,7 +144,7 @@ patternToDefs home rootName pattern =

141144-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS

142145

143146

144−patternToSubstitutions :: Opt.Expr -> P.Canonical -> [(String, Opt.Expr)]

147+patternToSubstitutions :: Opt.Expr -> P.Canonical -> [(Text, Opt.Expr)]

145148patternToSubstitutions expr (A.A _ pattern) =

146149 case pattern of

147150 P.Var name ->

@@ -159,7 +162,7 @@ patternToSubstitutions expr (A.A _ pattern) =

159162 P.Alias alias realPattern ->

160163 (alias, expr) : patternToSubstitutions expr realPattern

161164

162− P.Data _ patterns ->

165+ P.Ctor _ patterns ->

163166 concat (zipWith (patternToSubstitutions . Opt.CtorAccess expr) [0..] patterns)

164167

165168

@@ -167,7 +170,7 @@ patternToSubstitutions expr (A.A _ pattern) =

167170-- OPTIMIZE EXPRESSIONS

168171

169172

170−type Context = Maybe (String, Int, [String])

173+type Context = Maybe (Text, Int, [Text])

171174

172175

173176{-| This optimizer detects tail calls. The `Context` holds a function name,

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

193196 pure (Opt.Literal lit)

194197

195198 Can.Var name ->

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

199+ if name == Var.inCore "Debug" "crash" then

197200 do home <- Env.getHome

198201 pure (Opt.Crash home region Nothing)

199202

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

219222 (func:args) =

220223 Can.collectApps annExpr

221224 in

222− case isTailCall context func (length args) of

225+ case getTailCallInfo context func (length args) of

223226 Just (name, argNames) ->

224227 do optArgs <- T.traverse justConvert args

225228 Env.setTailCall True

@@ -254,7 +257,7 @@ optimizeExpr context annExpr@(A.A region expression) =

254257 let optCase = Case.optimize variantDict name optBranches

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

256259

257− Can.Ctor name exprs ->

260+ Can.Ctor (Var.Canonical _ name) exprs ->

258261 Opt.Ctor name <$> T.traverse justConvert exprs

259262

260263 Can.Access record field ->

@@ -305,7 +308,7 @@ mapSnd func (x, a) =

305308optimizeBranch

306309 :: Context

307310 -> R.Region

308− -> String

311+ -> Text

309312 -> (P.Canonical, Can.Expr)

310313 -> Env.Optimizer (P.Canonical, Opt.Expr)

311314optimizeBranch context region exprName (rawPattern, canBranch) =

@@ -344,8 +347,8 @@ tagCrashBranch region pattern@(A.A pr _) expr =

344347-- DETECT TAIL CALL

345348

346349

347−isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])

348−isTailCall context (A.A _ function) arity =

350+getTailCallInfo :: Context -> Can.Expr -> Int -> Maybe (Text, [Text])

351+getTailCallInfo context (A.A _ function) arity =

349352 case (context, function) of

350353 ( Just (ctxName, ctxArity, argNames), Can.Var (Var.Canonical home name) ) ->

351354

@@ -366,7 +369,7 @@ isTailCall context (A.A _ function) arity =

366369-- it out from there

367370

368371

369−depattern :: P.Canonical -> Can.Expr -> Env.Optimizer (String, Can.Expr)

372+depattern :: P.Canonical -> Can.Expr -> Env.Optimizer (Text, Can.Expr)

370373depattern canPattern@(A.A _ pattern) expr =

371374 let

372375 ann =

@@ -402,7 +405,7 @@ depattern canPattern@(A.A _ pattern) expr =

402405 P.Alias _ _ ->

403406 caseify

404407

405− P.Data _ _ ->

408+ P.Ctor _ _ ->

406409 caseify

407410

408411

@@ -444,9 +447,9 @@ optimizeBinop context region op leftExpr rightExpr =

444447 let body = collect makeRoot right backwardCompose binop

445448 optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))

446449

447− else if op == Var.Canonical Var.BuiltIn "::" then

450+ else if op == cons then

448451

449− optimizeExpr context (ann (Can.Ctor "::" [ leftExpr, rightExpr ]))

452+ optimizeExpr context (ann (Can.Ctor cons [ leftExpr, rightExpr ]))

450453

451454 else

452455

@@ -458,25 +461,30 @@ optimizeBinop context region op leftExpr rightExpr =

458461-- left-associative ((x |> f) |> g)

459462forwardApply :: Var.Canonical

460463forwardApply =

461− Var.inCore ["Basics"] "|>"

464+ Var.inCore "Basics" "|>"

462465

463466

464467-- right-associative (g <| (f <| x))

465468backwardApply :: Var.Canonical

466469backwardApply =

467− Var.inCore ["Basics"] "<|"

470+ Var.inCore "Basics" "<|"

468471

469472

470473-- left-associative ((f >> g) >> h)

471474forwardCompose :: Var.Canonical

472475forwardCompose =

473− Var.inCore ["Basics"] ">>"

476+ Var.inCore "Basics" ">>"

474477

475478

476479-- right-associative (h << (g << f))

477480backwardCompose :: Var.Canonical

478481backwardCompose =

479− Var.inCore ["Basics"] "<<"

482+ Var.inCore "Basics" "<<"

483+

484+

485+cons :: Var.Canonical

486+cons =

487+ Var.Canonical Var.BuiltIn "::"

480488

481489

482490type Assoc =

src/Optimize/Case.hs+3−2

@@ -5,6 +5,7 @@ import Control.Arrow (second)

55import qualified Data.Map as Map

66import Data.Map ((!))

77import qualified Data.Maybe as Maybe

8+import Data.Text (Text)

910import qualified AST.Expression.Optimized as Opt

1011import qualified AST.Pattern as P

@@ -15,7 +16,7 @@ import qualified Optimize.DecisionTree as DT

1516-- OPTIMIZE A CASE EXPRESSION

1617

1718

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

19+optimize :: DT.VariantDict -> Text -> [(P.Canonical, Opt.Expr)] -> Opt.Expr

1920optimize variantDict exprName optBranches =

2021 let

2122 (patterns, indexedBranches) =

@@ -38,7 +39,7 @@ indexify index (pattern, branch) =

3839-- CONVERT A TREE TO AN EXPRESSION

3940

4041

41−treeToExpr :: String -> DT.DecisionTree -> [(Int, Opt.Expr)] -> Opt.Expr

42+treeToExpr :: Text -> DT.DecisionTree -> [(Int, Opt.Expr)] -> Opt.Expr

4243treeToExpr name decisionTree allJumps =

4344 let

4445 decider =

src/Optimize/DecisionTree.hs+9−7

@@ -16,6 +16,8 @@ import qualified Data.List as List

1616import qualified Data.Map as Map

1717import qualified Data.Set as Set

1818import qualified Data.Maybe as Maybe

19+import qualified Data.Text as Text

20+import Data.Text (Text)

1921

2022import qualified AST.Helpers as Help

2123import qualified AST.Literal as L

@@ -61,7 +63,7 @@ contain things like [ ("Just", 2), ("Nothing", 2), ("_Tuple2", 1), ... ] which

6163we can use for these optimizations.

6264-}

6365type VariantDict =

64− Map.Map Var.Home (Map.Map String Int)

66+ Map.Map Var.Home (Map.Map Text Int)

6567

6668

6769-- DECISION TREES

@@ -84,7 +86,7 @@ data Test

8486

8587data Path

8688 = Position Int Path

87− | Field String Path

89+ | Field Text Path

8890 | Empty

8991 | Alias

9092 deriving (Eq)

@@ -181,7 +183,7 @@ getArity variantDict (Var.Canonical home name) =

181183

182184 Nothing ->

183185 if Help.isTuple name then

184− read (drop 6 name)

186+ read (drop 6 (Text.unpack name))

185187

186188 else

187189 error

@@ -216,7 +218,7 @@ flatten variantDict pathPattern@(path, A.A ann pattern) =

216218 P.Record _ ->

217219 [pathPattern]

218220

219− P.Data tag patterns ->

221+ P.Ctor tag patterns ->

220222 if getArity variantDict tag == 1 then

221223 concatMap (flatten variantDict) (subPositions path patterns)

222224

@@ -291,7 +293,7 @@ testAtPath selectedPath (Branch _ pathPatterns) =

291293

292294 Just (A.A _ pattern) ->

293295 case pattern of

294− P.Data name _ ->

296+ P.Ctor name _ ->

295297 Just (Constructor name)

296298

297299 P.Literal lit ->

@@ -324,7 +326,7 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

324326 case extract path pathPatterns of

325327 Just (start, A.A _ pattern, end) ->

326328 case pattern of

327− P.Data name patterns ->

329+ P.Ctor name patterns ->

328330 if test == Constructor name then

329331 Just (Branch goal (start ++ subPositions path patterns ++ end))

330332

@@ -394,7 +396,7 @@ needsTests (A.A _ pattern) =

394396 P.Record _ ->

395397 False

396398

397− P.Data _ _ ->

399+ P.Ctor _ _ ->

398400 True

399401

400402 P.Literal _ ->

src/Optimize/Environment.hs+6−2

@@ -1,3 +1,5 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

13module Optimize.Environment

24 ( Optimizer, run

35 , Env

@@ -8,6 +10,8 @@ module Optimize.Environment

810 ) where

911

1012import qualified Control.Monad.State as State

13+import qualified Data.Text as Text

14+import Data.Text (Text)

1115

1216import qualified AST.Module.Name as ModuleName

1317import qualified Optimize.DecisionTree as DT

@@ -51,9 +55,9 @@ setTailCall bool =

5155 State.put (env { _hasTailCall = bool })

5256

5357

54−freshName :: Optimizer String

58+freshName :: Optimizer Text

5559freshName =

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

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

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

62+ return (Text.append "_p" (Text.pack (show uid)))

5963

src/Optimize/Inline.hs+10−8

@@ -1,10 +1,12 @@

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

23module Optimize.Inline (inline) where

45import Control.Arrow (second, (***))

56import Control.Monad (foldM)

67import qualified Data.List as List

78import qualified Data.Map as Map

9+import Data.Text (Text)

810

911import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))

1012import qualified AST.Expression.Optimized as Opt

@@ -13,7 +15,7 @@ import qualified Optimize.Environment as Env

1315

1416

1517

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

18+inline :: Map.Map Text Opt.Expr -> Opt.Expr -> Env.Optimizer Opt.Expr

1719inline rawSubs expression =

1820 let

1921 counts =

@@ -33,12 +35,12 @@ inline rawSubs expression =

3335

3436

3537data Subs = Subs

36− { _substitutions :: Map.Map String Opt.Expr

37− , _definitions :: [(String, Opt.Expr)]

38+ { _substitutions :: Map.Map Text Opt.Expr

39+ , _definitions :: [(Text, Opt.Expr)]

3840 }

3941

4042

41−processSubs :: Subs -> (String, (Int, Opt.Expr)) -> Env.Optimizer Subs

43+processSubs :: Subs -> (Text, (Int, Opt.Expr)) -> Env.Optimizer Subs

4244processSubs (Subs subs defs) (name, (n, expr)) =

4345 if n == 1 then

4446 return $ Subs (Map.insert name expr subs) defs

@@ -54,12 +56,12 @@ processSubs (Subs subs defs) (name, (n, expr)) =

5456-- HELPERS

5557

5658

57−deleteBatch :: [String] -> Map.Map String a -> Map.Map String a

59+deleteBatch :: [Text] -> Map.Map Text a -> Map.Map Text a

5860deleteBatch names dict =

5961 List.foldl' (flip Map.delete) dict names

6062

6163

62−getDefName :: Opt.Def -> String

64+getDefName :: Opt.Def -> Text

6365getDefName def =

6466 case def of

6567 Opt.Def _ name _ ->

@@ -73,7 +75,7 @@ getDefName def =

7375-- COUNT VARIABLE APPEARANCES

7476

7577

76−count :: Opt.Expr -> Map.Map String Int

78+count :: Opt.Expr -> Map.Map Text Int

7779count expression =

7880 let

7981 count2 a b =

@@ -192,7 +194,7 @@ count expression =

192194-- REPLACE

193195

194196

195−replace :: Map.Map String Opt.Expr -> Opt.Expr -> Opt.Expr

197+replace :: Map.Map Text Opt.Expr -> Opt.Expr -> Opt.Expr

196198replace substitutions expression =

197199 let

198200 go = replace substitutions