5b4fbc7 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Upgrade Optimize code from String to Text

5b4fbc7Evan Czaplicki10 years ago

src/Optimize.hs+33−25

compare with master

unifiedsplit

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

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

1module Optimize (optimize) where

3module Optimize (optimize) where

3import qualified Control.Monad as M

5import qualified Control.Monad as M

4import qualified Data.Map as Map

6import qualified Data.Map as Map

5import qualified Data.Traversable as T

7import qualified Data.Traversable as T

8+import Data.Text (Text)

7import qualified AST.Expression.Canonical as Can

10import qualified AST.Expression.Canonical as Can

8import qualified AST.Expression.Optimized as Opt

11import qualified AST.Expression.Optimized as Opt

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

53 -> [P.Canonical]

56 -> [P.Canonical]

54 -> Can.Expr

57 -> Can.Expr

55 -> Env.Optimizer [Opt.Def]

58 -> Env.Optimizer [Opt.Def]

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

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

57 let

60 let

58 facts =

61 facts =

59 Opt.Facts home

62 Opt.Facts home

60 in

63 in

61− case (ptrn, args) of

64+ case (ptrn, rawArgs) of

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

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

64 do htc <- Env.getTailCall

67 do htc <- Env.getTailCall

65 Env.setTailCall False

68 Env.setTailCall False

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

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

69 isTailCall <- Env.getTailCall

72 isTailCall <- Env.getTailCall

70 Env.setTailCall htc

73 Env.setTailCall htc

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

102

100

103

101optimizeFunction

104optimizeFunction

102− :: Maybe String

105+ :: Maybe Text

103 -> [P.Canonical]

106 -> [P.Canonical]

104 -> Can.Expr

107 -> Can.Expr

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

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

106optimizeFunction maybeName patterns givenBody =

109optimizeFunction maybeName patterns givenBody =

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

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

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

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

109 return (argNames, optBody)

112 return (argNames, optBody)

110

113

111

114

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

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

113makeContext argNames name =

116makeContext argNames name =

114 Just (name, length argNames, argNames)

117 Just (name, length argNames, argNames)

115

118

116

119

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

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

118depatternArgs (names, rawExpr) ptrn =

121depatternArgs (names, rawExpr) ptrn =

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

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

120 return (name : names, expr)

123 return (name : names, expr)

121

124

122

125

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

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

124patternToDefs home rootName pattern =

127patternToDefs home rootName pattern =

125 let

128 let

126 rootExpr =

129 rootExpr =

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

141-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS

144-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS

142

145

143

146

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

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

145patternToSubstitutions expr (A.A _ pattern) =

148patternToSubstitutions expr (A.A _ pattern) =

146 case pattern of

149 case pattern of

147 P.Var name ->

150 P.Var name ->

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

159 P.Alias alias realPattern ->

162 P.Alias alias realPattern ->

160 (alias, expr) : patternToSubstitutions expr realPattern

163 (alias, expr) : patternToSubstitutions expr realPattern

161

164

162− P.Data _ patterns ->

165+ P.Ctor _ patterns ->

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

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

164

167

165

168

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

167-- OPTIMIZE EXPRESSIONS

170-- OPTIMIZE EXPRESSIONS

168

171

169

172

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

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

171

174

172

175

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

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

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

193 pure (Opt.Literal lit)

196 pure (Opt.Literal lit)

194

197

195 Can.Var name ->

198 Can.Var name ->

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

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

197 do home <- Env.getHome

200 do home <- Env.getHome

198 pure (Opt.Crash home region Nothing)

201 pure (Opt.Crash home region Nothing)

199

202

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

219 (func:args) =

222 (func:args) =

220 Can.collectApps annExpr

223 Can.collectApps annExpr

221 in

224 in

222− case isTailCall context func (length args) of

225+ case getTailCallInfo context func (length args) of

223 Just (name, argNames) ->

226 Just (name, argNames) ->

224 do optArgs <- T.traverse justConvert args

227 do optArgs <- T.traverse justConvert args

225 Env.setTailCall True

228 Env.setTailCall True

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

254 let optCase = Case.optimize variantDict name optBranches

257 let optCase = Case.optimize variantDict name optBranches

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

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

256

259

257− Can.Ctor name exprs ->

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

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

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

259

262

260 Can.Access record field ->

263 Can.Access record field ->

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

305optimizeBranch

308optimizeBranch

306 :: Context

309 :: Context

307 -> R.Region

310 -> R.Region

308− -> String

311+ -> Text

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

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

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

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

311optimizeBranch context region exprName (rawPattern, canBranch) =

314optimizeBranch context region exprName (rawPattern, canBranch) =

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

344-- DETECT TAIL CALL

347-- DETECT TAIL CALL

345

348

346

349

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

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

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

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

349 case (context, function) of

352 case (context, function) of

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

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

351

354

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

366-- it out from there

369-- it out from there

367

370

368

371

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

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

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

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

371 let

374 let

372 ann =

375 ann =

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

402 P.Alias _ _ ->

405 P.Alias _ _ ->

403 caseify

406 caseify

404

407

405− P.Data _ _ ->

408+ P.Ctor _ _ ->

406 caseify

409 caseify

407

410

408

411

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

444 let body = collect makeRoot right backwardCompose binop

447 let body = collect makeRoot right backwardCompose binop

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

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

446

449

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

450+ else if op == cons then

448

451

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

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

450

453

451 else

454 else

452

455

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

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

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

459forwardApply :: Var.Canonical

462forwardApply :: Var.Canonical

460forwardApply =

463forwardApply =

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

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

462

465

463

466

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

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

465backwardApply :: Var.Canonical

468backwardApply :: Var.Canonical

466backwardApply =

469backwardApply =

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

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

468

471

469

472

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

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

471forwardCompose :: Var.Canonical

474forwardCompose :: Var.Canonical

472forwardCompose =

475forwardCompose =

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

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

474

477

475

478

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

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

477backwardCompose :: Var.Canonical

480backwardCompose :: Var.Canonical

478backwardCompose =

481backwardCompose =

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

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

483+

484+

485+cons :: Var.Canonical

486+cons =

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

480

488

481

489

482type Assoc =

490type Assoc =

src/Optimize/Case.hs+3−2

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

5import qualified Data.Map as Map

6import Data.Map ((!))

7import qualified Data.Maybe as Maybe

8+import Data.Text (Text)

9import qualified AST.Expression.Optimized as Opt

10import qualified AST.Expression.Optimized as Opt

10import qualified AST.Pattern as P

11import qualified AST.Pattern as P

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

15-- OPTIMIZE A CASE EXPRESSION

16-- OPTIMIZE A CASE EXPRESSION

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

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

19optimize variantDict exprName optBranches =

20optimize variantDict exprName optBranches =

20 let

21 let

21 (patterns, indexedBranches) =

22 (patterns, indexedBranches) =

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

38-- CONVERT A TREE TO AN EXPRESSION

39-- CONVERT A TREE TO AN EXPRESSION

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

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

42treeToExpr name decisionTree allJumps =

43treeToExpr name decisionTree allJumps =

43 let

44 let

44 decider =

45 decider =

src/Optimize/DecisionTree.hs+9−7

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

16import qualified Data.Map as Map

17import qualified Data.Set as Set

18import qualified Data.Maybe as Maybe

19+import qualified Data.Text as Text

20+import Data.Text (Text)

20import qualified AST.Helpers as Help

22import qualified AST.Helpers as Help

21import qualified AST.Literal as L

23import qualified AST.Literal as L

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

61we can use for these optimizations.

63we can use for these optimizations.

62-}

64-}

63type VariantDict =

65type VariantDict =

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

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

67-- DECISION TREES

69-- DECISION TREES

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

85data Path

87data Path

86 = Position Int Path

88 = Position Int Path

87− | Field String Path

89+ | Field Text Path

88 | Empty

90 | Empty

89 | Alias

91 | Alias

90 deriving (Eq)

92 deriving (Eq)

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

181

183

182 Nothing ->

184 Nothing ->

183 if Help.isTuple name then

185 if Help.isTuple name then

184− read (drop 6 name)

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

185

187

186 else

188 else

187 error

189 error

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

216 P.Record _ ->

218 P.Record _ ->

217 [pathPattern]

219 [pathPattern]

218

220

219− P.Data tag patterns ->

221+ P.Ctor tag patterns ->

220 if getArity variantDict tag == 1 then

222 if getArity variantDict tag == 1 then

221 concatMap (flatten variantDict) (subPositions path patterns)

223 concatMap (flatten variantDict) (subPositions path patterns)

222

224

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

291

293

292 Just (A.A _ pattern) ->

294 Just (A.A _ pattern) ->

293 case pattern of

295 case pattern of

294− P.Data name _ ->

296+ P.Ctor name _ ->

295 Just (Constructor name)

297 Just (Constructor name)

296

298

297 P.Literal lit ->

299 P.Literal lit ->

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

324 case extract path pathPatterns of

326 case extract path pathPatterns of

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

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

326 case pattern of

328 case pattern of

327− P.Data name patterns ->

329+ P.Ctor name patterns ->

328 if test == Constructor name then

330 if test == Constructor name then

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

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

330

332

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

394 P.Record _ ->

396 P.Record _ ->

395 False

397 False

396

398

397− P.Data _ _ ->

399+ P.Ctor _ _ ->

398 True

400 True

399

401

400 P.Literal _ ->

402 P.Literal _ ->

src/Optimize/Environment.hs+6−2

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

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

1module Optimize.Environment

3module Optimize.Environment

2 ( Optimizer, run

4 ( Optimizer, run

3 , Env

5 , Env

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

8 ) where

10 ) where

10import qualified Control.Monad.State as State

12import qualified Control.Monad.State as State

13+import qualified Data.Text as Text

14+import Data.Text (Text)

12import qualified AST.Module.Name as ModuleName

16import qualified AST.Module.Name as ModuleName

13import qualified Optimize.DecisionTree as DT

17import qualified Optimize.DecisionTree as DT

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

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

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

54−freshName :: Optimizer String

58+freshName :: Optimizer Text

55freshName =

59freshName =

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

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

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

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

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

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

src/Optimize/Inline.hs+10−8

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

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Optimize.Inline (inline) where

3module Optimize.Inline (inline) where

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

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

5import Control.Monad (foldM)

6import Control.Monad (foldM)

6import qualified Data.List as List

7import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Map as Map

9+import Data.Text (Text)

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

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

10import qualified AST.Expression.Optimized as Opt

12import qualified AST.Expression.Optimized as Opt

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

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

17inline rawSubs expression =

19inline rawSubs expression =

18 let

20 let

19 counts =

21 counts =

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

35data Subs = Subs

37data Subs = Subs

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

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

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

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

38 }

40 }

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

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

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

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

43 if n == 1 then

45 if n == 1 then

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

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

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

54-- HELPERS

56-- HELPERS

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

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

58deleteBatch names dict =

60deleteBatch names dict =

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

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

62−getDefName :: Opt.Def -> String

64+getDefName :: Opt.Def -> Text

63getDefName def =

65getDefName def =

64 case def of

66 case def of

65 Opt.Def _ name _ ->

67 Opt.Def _ name _ ->

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

73-- COUNT VARIABLE APPEARANCES

75-- COUNT VARIABLE APPEARANCES

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

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

77count expression =

79count expression =

78 let

80 let

79 count2 a b =

81 count2 a b =

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

192-- REPLACE

194-- REPLACE

193

195

194

196

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

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

196replace substitutions expression =

198replace substitutions expression =

197 let

199 let

198 go = replace substitutions

200 go = replace substitutions